[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Utilisation gfc_clear_descriptor dans gfc_conv_derived_to_class
https://gcc.gnu.org/g:db8dddefb7b3659f1307058b98421fc9edf2e6de
commit db8dddefb7b3659f1307058b98421fc9edf2e6de
Author: Mikael Morin
Date: Wed Dec 11 16:03:10 2024 +0100
Utilisation gfc_clear_descriptor dans gfc_conv_derived_to_class
essai suppression
Suppression fonction inutilisée
Sauvegarde compilation OK
Correction régression
Sauvegarde correction null_actual_6
Commentage fonction inutilisée
Correction bornes descripteur null
Diff:
---
gcc/fortran/trans-array.cc | 339 +++--
gcc/fortran/trans-array.h | 4 +-
gcc/fortran/trans-expr.cc | 87 ++--
3 files changed, 373 insertions(+), 57 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index d15576adde10..0370d10d9ebd 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -592,10 +592,10 @@ get_size_info (gfc_typespec &ts)
if (POINTER_TYPE_P (type))
type = TREE_TYPE (type);
gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
- tree elt_type = TREE_TYPE (type);
+ tree char_type = TREE_TYPE (type);
tree len = ts.u.cl->backend_decl;
return fold_build2_loc (input_location, MULT_EXPR, size_type_node,
- size_in_bytes (elt_type),
+ size_in_bytes (char_type),
fold_convert (size_type_node, len));
}
@@ -613,8 +613,61 @@ get_size_info (gfc_typespec &ts)
}
+class init_info
+{
+public:
+ virtual bool initialize_data () const { return false; }
+ virtual tree get_data_value () const { return NULL_TREE; }
+ virtual gfc_typespec *get_type () const { return nullptr; }
+};
+
+
+class default_init : public init_info
+{
+private:
+ const symbol_attribute &attr;
+
+public:
+ default_init (const symbol_attribute &arg_attr) : attr(arg_attr) { }
+ virtual bool initialize_data () const { return !attr.pointer; }
+ virtual tree get_data_value () const {
+if (!initialize_data ())
+ return NULL_TREE;
+
+return null_pointer_node;
+ }
+};
+
+class nullification : public init_info
+{
+private:
+ gfc_typespec &ts;
+
+public:
+ nullification(gfc_typespec &arg_ts) : ts(arg_ts) { }
+ virtual bool initialize_data () const { return true; }
+ virtual tree get_data_value () const { return null_pointer_node; }
+ virtual gfc_typespec *get_type () const { return &ts; }
+};
+
+class scalar_value : public init_info
+{
+private:
+ gfc_typespec &ts;
+ tree value;
+
+public:
+ scalar_value(gfc_typespec &arg_ts, tree arg_value)
+: ts(arg_ts), value(arg_value) { }
+ virtual bool initialize_data () const { return true; }
+ virtual tree get_data_value () const { return value; }
+ virtual gfc_typespec *get_type () const { return &ts; }
+};
+
+
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 *v = nullptr;
@@ -622,11 +675,17 @@ build_dtype (gfc_typespec &ts, int rank, const
symbol_attribute &)
tree fields = TYPE_FIELDS (type);
- if (ts.type != BT_CLASS)
+ gfc_typespec *type_info = init.get_type ();
+ if (type_info == nullptr)
+type_info = &ts;
+
+ if (!(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 (ts));
+ get_size_info (*type_info));
CONSTRUCTOR_APPEND_ELT (v, elem_len_field, elem_len_val);
}
@@ -641,11 +700,11 @@ build_dtype (gfc_typespec &ts, int rank, const
symbol_attribute &)
CONSTRUCTOR_APPEND_ELT (v, rank_field, rank_val);
}
- if (ts.type != BT_CLASS)
+ if (type_info->type != BT_CLASS)
{
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 (ts));
+ get_type_info (*type_info));
CONSTRUCTOR_APPEND_ELT (v, type_info_field, type_info_val);
}
@@ -656,8 +715,8 @@ build_dtype (gfc_typespec &ts, int rank, const
symbol_attribute &)
/* Build a null array descriptor constructor. */
vec *
-get_default_descriptor_init (tree type, gfc_typespec &ts, int rank,
-const symbol_attribute &attr)
+get_descriptor_init (tree type, gfc_typespec &ts, int rank,
+const symbol_attribute &attr, const init_info &init)
{
vec *v = nullptr;
@@ -666,15 +725,15 @@ get_default_descriptor_init (tree type, gfc_typespec &ts,
int rank,
tree fields = TYPE_FIELDS (type);
/* Don't init pointers by default. */
- if
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation shift descriptor
https://gcc.gnu.org/g:7421792ba1ee3c272b294ac19a85bc43ad73e3c7
commit 7421792ba1ee3c272b294ac19a85bc43ad73e3c7
Author: Mikael Morin
Date: Thu Jan 16 14:35:14 2025 +0100
Factorisation shift descriptor
Diff:
---
gcc/fortran/trans-array.cc | 6 +++---
gcc/fortran/trans-array.h | 1 +
gcc/fortran/trans-stmt.cc | 6 +-
3 files changed, 5 insertions(+), 8 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index ec0badd0dc33..ecdaad3f9575 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1257,8 +1257,8 @@ conv_shift_descriptor (stmtblock_t *block, tree desc, int
rank,
}
-static void
-conv_shift_descriptor (stmtblock_t* block, tree desc, int rank)
+void
+gfc_conv_shift_descriptor (stmtblock_t* block, tree desc, int rank)
{
conv_shift_descriptor (block, desc, rank, unset_lb ());
}
@@ -10103,7 +10103,7 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr,
bool g77,
gfc_init_block (&block);
if (maybe_shift && !keep_descriptor_lower_bound (expr))
- conv_shift_descriptor (&block, se->expr, expr->rank);
+ gfc_conv_shift_descriptor (&block, se->expr, expr->rank);
bool assumed_rank_fsym;
if (fsym
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 571322ae11ff..378afb9617a3 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -216,6 +216,7 @@ tree gfc_get_cfi_dim_sm (tree, tree);
/* Shift lower bound of descriptor, updating ubound and offset. */
void gfc_conv_shift_descriptor_lbound (stmtblock_t*, tree, int, tree);
void gfc_conv_shift_descriptor (stmtblock_t*, tree, const gfc_array_ref &);
+void gfc_conv_shift_descriptor (stmtblock_t*, tree, int);
void gfc_conv_shift_descriptor (stmtblock_t*, tree, tree, int, tree);
/* Add pre-loop scalarization code for intrinsic functions which require
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index e7da8fea3b24..01fb8d91007f 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -2007,16 +2007,12 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block
*block)
if ((!sym->assoc->variable && !cst_array_ctor)
|| !whole_array)
{
- int dim;
-
if (whole_array)
gfc_add_modify (&se.pre, desc, se.expr);
/* The generated descriptor has lower bound zero (as array
temporary), shift bounds so we get lower bounds of 1. */
- for (dim = 0; dim < e->rank; ++dim)
- gfc_conv_shift_descriptor_lbound (&se.pre, desc,
- dim, gfc_index_one_node);
+ gfc_conv_shift_descriptor (&se.pre, desc, e->rank);
}
/* If this is a subreference array pointer associate name use the
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Déplacement shift descriptor vers gfc_conv_array_parameter
https://gcc.gnu.org/g:063c0014407236e53fa5c3734cab2f3fec5fa03f
commit 063c0014407236e53fa5c3734cab2f3fec5fa03f
Author: Mikael Morin
Date: Tue Dec 17 17:27:24 2024 +0100
Déplacement shift descriptor vers gfc_conv_array_parameter
Suppression variables inutilisées
Diff:
---
gcc/fortran/trans-array.cc | 49 ++
gcc/fortran/trans-array.h | 2 +-
gcc/fortran/trans-expr.cc | 20 +--
3 files changed, 43 insertions(+), 28 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 0370d10d9ebd..2fdd15962e49 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1151,6 +1151,43 @@ gfc_conv_shift_descriptor_lbound (stmtblock_t* block,
tree desc,
}
+static void
+conv_shift_descriptor (stmtblock_t* block, tree desc, int rank)
+{
+ /* Apply a shift of the lbound when supplied. */
+ for (int dim = 0; dim < rank; ++dim)
+gfc_conv_shift_descriptor_lbound (block, desc, dim,
+ gfc_index_one_node);
+}
+
+
+static bool
+keep_descriptor_lower_bound (gfc_expr *e)
+{
+ gfc_ref *ref;
+
+ /* Detect any array references with vector subscripts. */
+ for (ref = e->ref; ref; ref = ref->next)
+if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT
+ && ref->u.ar.type != AR_FULL)
+ {
+ int dim;
+ for (dim = 0; dim < ref->u.ar.dimen; dim++)
+ if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
+ break;
+ if (dim < ref->u.ar.dimen)
+ break;
+ }
+
+ /* Array references with vector subscripts and non-variable
+ expressions need be converted to a one-based descriptor. */
+ if (ref || e->expr_type != EXPR_VARIABLE)
+return false;
+
+ return true;
+}
+
+
/* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
void
@@ -9454,7 +9491,7 @@ is_pointer (gfc_expr *e)
void
gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77,
const gfc_symbol *fsym, const char *proc_name,
- tree *size, tree *lbshift, tree *packed)
+ tree *size, bool maybe_shift, tree *packed)
{
tree ptr;
tree desc;
@@ -9690,13 +9727,9 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr,
bool g77,
stmtblock_t block;
gfc_init_block (&block);
- if (lbshift && *lbshift)
- {
- /* Apply a shift of the lbound when supplied. */
- for (int dim = 0; dim < expr->rank; ++dim)
- gfc_conv_shift_descriptor_lbound (&block, se->expr, dim,
- *lbshift);
- }
+ if (maybe_shift && !keep_descriptor_lower_bound (expr))
+ conv_shift_descriptor (&block, se->expr, expr->rank);
+
tmp = gfc_class_data_get (ctree);
if (expr->rank > 1 && CLASS_DATA (fsym)->as->rank != expr->rank
&& CLASS_DATA (fsym)->as->type == AS_EXPLICIT && !no_pack)
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 78646275b4ec..17e3d08fdba0 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -158,7 +158,7 @@ tree gfc_get_array_span (tree, gfc_expr *);
void gfc_conv_expr_descriptor (gfc_se *, gfc_expr *);
/* Convert an array for passing as an actual function parameter. */
void gfc_conv_array_parameter (gfc_se *, gfc_expr *, bool, const gfc_symbol *,
- const char *, tree *, tree * = nullptr,
+ const char *, tree *, bool = false,
tree * = nullptr);
/* These work with both descriptors and descriptorless arrays. */
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 6978f83cdc8c..e8b229d853e3 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -991,8 +991,6 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
gfc_symbol *fsym,
stmtblock_t block;
gfc_init_block (&block);
gfc_ref *ref;
- int dim;
- tree lbshift = NULL_TREE;
/* Array refs with sections indicate, that a for a formal argument
expecting contiguous repacking needs to be done. */
@@ -1005,25 +1003,9 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
gfc_symbol *fsym,
&& (ref || e->rank != fsym->ts.u.derived->components->as->rank))
fsym->attr.contiguous = 1;
- /* Detect any array references with vector subscripts. */
- for (ref = e->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT
- && ref->u.ar.type != AR_FULL)
- {
- for (dim = 0; dim < ref->u.ar.dimen; dim++)
- if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
- break;
- if (dim < ref->u.ar.dimen)
- break;
- }
-
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation shift descriptor
https://gcc.gnu.org/g:c2ce7393ce79293896ae05dcfff402ffea2c9176
commit c2ce7393ce79293896ae05dcfff402ffea2c9176
Author: Mikael Morin
Date: Tue Jan 21 22:27:02 2025 +0100
Factorisation shift descriptor
Diff:
---
gcc/fortran/trans-array.cc | 117 -
gcc/fortran/trans-array.h | 1 +
gcc/fortran/trans-expr.cc | 82 ++-
3 files changed, 100 insertions(+), 100 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index b05f69fdd874..7afa29746e08 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1198,16 +1198,52 @@ conv_shift_descriptor_lbound (stmtblock_t* block, tree
desc, int dim,
}
-class lb_info
+class lb_info_base
{
public:
+ virtual tree lower_bound (stmtblock_t *block, int dim) const = 0;
+};
+
+
+class lb_info : public lb_info_base
+{
+public:
+ using lb_info_base::lower_bound;
virtual gfc_expr *lower_bound (int dim) const = 0;
+ virtual tree lower_bound (stmtblock_t *block, int dim) const;
};
+tree
+lb_info::lower_bound (stmtblock_t *block, int dim) const
+{
+ gfc_expr *lb_expr = lower_bound(dim);
+
+ if (lb_expr == nullptr)
+return gfc_index_one_node;
+ else
+{
+ gfc_se lb_se;
+
+ gfc_init_se (&lb_se, nullptr);
+ gfc_conv_expr (&lb_se, lb_expr);
+
+ gfc_add_block_to_block (block, &lb_se.pre);
+ tree lb_var = gfc_create_var (gfc_array_index_type, "lower_bound");
+ gfc_add_modify (block, lb_var,
+ fold_convert (gfc_array_index_type, lb_se.expr));
+ gfc_add_block_to_block (block, &lb_se.post);
+
+ return lb_var;
+}
+}
+
+
+
class unset_lb : public lb_info
{
public:
+ using lb_info::lower_bound;
virtual gfc_expr *lower_bound (int) const { return nullptr; }
};
@@ -1218,6 +1254,7 @@ class defined_lb : public lb_info
gfc_expr * const * lower_bounds;
public:
+ using lb_info::lower_bound;
defined_lb (int arg_rank, gfc_expr * const
arg_lower_bounds[GFC_MAX_DIMENSIONS])
: rank(arg_rank), lower_bounds(arg_lower_bounds) { }
virtual gfc_expr *lower_bound (int dim) const { return lower_bounds[dim]; }
@@ -1226,7 +1263,7 @@ public:
static void
conv_shift_descriptor (stmtblock_t *block, tree desc, int rank,
- const lb_info &info)
+ const lb_info_base &info)
{
tree tmp = gfc_conv_descriptor_offset_get (desc);
tree offset_var = gfc_create_var (TREE_TYPE (tmp), "offset");
@@ -1235,26 +1272,7 @@ conv_shift_descriptor (stmtblock_t *block, tree desc,
int rank,
/* Apply a shift of the lbound when supplied. */
for (int dim = 0; dim < rank; ++dim)
{
- gfc_expr *lb_expr = info.lower_bound(dim);
-
- tree lower_bound;
- if (lb_expr == nullptr)
- lower_bound = gfc_index_one_node;
- else
- {
- gfc_se lb_se;
-
- gfc_init_se (&lb_se, nullptr);
- gfc_conv_expr (&lb_se, lb_expr);
-
- gfc_add_block_to_block (block, &lb_se.pre);
- tree lb_var = gfc_create_var (TREE_TYPE (lb_se.expr), "lower_bound");
- gfc_add_modify (block, lb_var, lb_se.expr);
- gfc_add_block_to_block (block, &lb_se.post);
-
- lower_bound = lb_var;
- }
-
+ tree lower_bound = info.lower_bound (block, dim);
conv_shift_descriptor_lbound (block, desc, dim, lower_bound, offset_var);
}
@@ -1337,6 +1355,61 @@ gfc_conv_shift_descriptor (stmtblock_t *block, tree desc,
}
+class dataref_lb : public lb_info_base
+{
+ gfc_array_spec *as;
+ gfc_expr *conv_arg;
+ tree desc;
+
+public:
+ dataref_lb (gfc_array_spec *arg_as, gfc_expr *arg_conv_arg, tree arg_desc)
+: as(arg_as), conv_arg (arg_conv_arg), desc (arg_desc)
+ {}
+ virtual tree lower_bound (stmtblock_t *block, int dim) const;
+};
+
+
+tree
+dataref_lb::lower_bound (stmtblock_t *block, int dim) const
+{
+ tree lbound;
+ if (as && as->lower[dim])
+{
+ gfc_se lbse;
+ gfc_init_se (&lbse, NULL);
+ gfc_conv_expr (&lbse, as->lower[dim]);
+ gfc_add_block_to_block (block, &lbse.pre);
+ lbound = gfc_evaluate_now (lbse.expr, block);
+}
+ else if (as && conv_arg)
+{
+ tree tmp = gfc_get_symbol_decl (conv_arg->symtree->n.sym);
+ lbound = gfc_conv_descriptor_lbound_get (tmp, gfc_rank_cst[dim]);
+}
+ else if (as)
+lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
+ else
+lbound = gfc_index_one_node;
+
+ return fold_convert (gfc_array_index_type, lbound);
+}
+
+
+void
+gfc_conv_shift_descriptor_subarray (stmtblock_t *block, tree desc,
+ gfc_expr *value_expr, gfc_expr *conv_arg)
+{
+ /* Obtain the array spec of full array references. */
+ gfc_array_spec *as;
+ if (conv_arg)
+as = gfc_get_full_arrayspec_from_expr (conv_arg);
+ else
+as = gfc_get_full_arrayspec_from_expr (value_expr);
+
+ conv_shift_descriptor (block, desc, value_expr->rank, dataref_lb (as,
conv
[gcc] Deleted branch 'mikael/heads/refactor_descriptor_v01' in namespace 'refs/users'
The branch 'mikael/heads/refactor_descriptor_v01' in namespace 'refs/users' was deleted. It previously pointed to: 8773ceade0f9... Correction régression bound_10.f90 Diff: !!! WARNING: THE FOLLOWING COMMITS ARE NO LONGER ACCESSIBLE (LOST): --- 8773cea... Correction régression bound_10.f90 34c1131... Modifications mineures 4ffb2a2... Factorisation set_descriptor_dimension f052983... Factorisation gfc_conv_shift_descriptor. 7307f61... Factorisation gfc_conv_shift_descriptor 96c395b... Renseignement token par gfc_set_descriptor_from_scalar. cd99fad... Séparation motifs dump assumed_rank_12.f90 ac8ccbd... Annulation modif dump assumed_rank_12.f90 34baff5... Sauvegarde factorisation set_descriptor_from_scalar 47b6338... Déplacement gfc_set_gfc_from_cfi d292794... Déplacement gfc_copy_sequence_descriptor da0f060... Déplacement méthode set_descriptor_from_scalar 0aef327... Suppression code redondant 0838449... Update dump match count 01b40a5... Factorisation set_descriptor_from_scalar dans gfc_conv_scal c3d8cf0... Factorisation set_descriptor_from_scalar conv_derived_to_cl 60fb6b7... Factorisation set_descriptor_from_scalar dans conv_class_to 1392f13... Factorisation initialisation depuis cfi 84be5a4... utilisation booléen allocatable 57a9d25... Factorisation initialisation gfc depuis cfi 7d9a5b7... Refactoring gfc_conv_descriptor_sm_get. 55a2a10... Introduction gfc_conv_descriptor_extent_get c2ce739... Factorisation shift descriptor 41e3834... Factorisation initialisation subarray_descriptor c3a50c1... Factorisation set descriptor with shape b5834ef... Factorisation set_contiguous_array ccb2dcc... Factorisation set_contiguous_array bd3573d... Essai suppression unlimited_polymorphic a6d12d1... Refactor conv_shift_descriptor 7818e31... Factorisation shift descriptor 7421792... Factorisation shift descriptor d607595... Factorisation gfc_conv_expr_descriptor 82413c9... Factorisation copie gfc_conv_expr_descriptor ed6fee2... Extraction fonction fcncall_realloc_result 7ed0026... Factorisation gfc_conv_remap_descriptor 6d1a550... Introduction gfc_copy_sequence_descriptor b68e4d2... Utilisation de la méthode de nullification pour nullifier ecdc8da... Appel méthode shift descriptor dans gfc_trans_pointer_assi 063c001... Déplacement shift descriptor vers gfc_conv_array_parameter db8ddde... Utilisation gfc_clear_descriptor dans gfc_conv_derived_to_c e3de444... Sauvegarde modifs 3c45ca6... Creation méthode initialisation descripteur
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Creation méthode initialisation descripteur
https://gcc.gnu.org/g:3c45ca6ee9cb09354b7ede90cf410c13adeec82c
commit 3c45ca6ee9cb09354b7ede90cf410c13adeec82c
Author: Mikael Morin
Date: Thu Dec 5 20:30:08 2024 +0100
Creation méthode initialisation descripteur
Utilisation méthode initialisation descripteur gfc_trans_deferred_array
Correction variable inutilisée
Correction segmentation fault
Correction regression allocatable attribute
Ajout conversion elem_len
conversion type longueur chaine
Initialisation descripteur champ par champ
Silence uninitialized warning.
Diff:
---
gcc/fortran/expr.cc| 25 +++-
gcc/fortran/gfortran.h | 1 +
gcc/fortran/primary.cc | 84 +++-
gcc/fortran/trans-array.cc | 286 +
gcc/fortran/trans-intrinsic.cc | 2 +-
5 files changed, 333 insertions(+), 65 deletions(-)
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 7f3f6c52fb54..e4829448f710 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -5411,27 +5411,38 @@ gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
gfc_ref *ref;
if (expr->rank == 0)
-return NULL;
+return nullptr;
/* Follow any component references. */
if (expr->expr_type == EXPR_VARIABLE
|| expr->expr_type == EXPR_CONSTANT)
{
- if (expr->symtree)
- as = expr->symtree->n.sym->as;
+ gfc_symbol *sym = expr->symtree ? expr->symtree->n.sym : nullptr;
+ if (sym
+ && sym->ts.type == BT_CLASS)
+ as = CLASS_DATA (sym)->as;
+ else if (sym)
+ as = sym->as;
else
- as = NULL;
+ as = nullptr;
for (ref = expr->ref; ref; ref = ref->next)
{
switch (ref->type)
{
case REF_COMPONENT:
- as = ref->u.c.component->as;
+ {
+ gfc_component *comp = ref->u.c.component;
+ if (comp->ts.type == BT_CLASS)
+ as = CLASS_DATA (comp)->as;
+ else
+ as = comp->as;
+ }
continue;
case REF_SUBSTRING:
case REF_INQUIRY:
+ as = nullptr;
continue;
case REF_ARRAY:
@@ -5441,7 +5452,7 @@ gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
case AR_ELEMENT:
case AR_SECTION:
case AR_UNKNOWN:
- as = NULL;
+ as = nullptr;
continue;
case AR_FULL:
@@ -5453,7 +5464,7 @@ gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
}
}
else
-as = NULL;
+as = nullptr;
return as;
}
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 7367db8853c6..b14857132ed7 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -4049,6 +4049,7 @@ const char *gfc_dt_lower_string (const char *);
const char *gfc_dt_upper_string (const char *);
/* primary.cc */
+symbol_attribute gfc_symbol_attr (gfc_symbol *);
symbol_attribute gfc_variable_attr (gfc_expr *, gfc_typespec *);
symbol_attribute gfc_expr_attr (gfc_expr *);
symbol_attribute gfc_caf_attr (gfc_expr *, bool i = false, bool *r = NULL);
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 8a38720422ec..c934841f4795 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2867,42 +2867,14 @@ check_substring:
}
-/* Given an expression that is a variable, figure out what the
- ultimate variable's type and attribute is, traversing the reference
- structures if necessary.
-
- This subroutine is trickier than it looks. We start at the base
- symbol and store the attribute. Component references load a
- completely new attribute.
-
- A couple of rules come into play. Subobjects of targets are always
- targets themselves. If we see a component that goes through a
- pointer, then the expression must also be a target, since the
- pointer is associated with something (if it isn't core will soon be
- dumped). If we see a full part or section of an array, the
- expression is also an array.
-
- We can have at most one full array reference. */
-
symbol_attribute
-gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
+gfc_symbol_attr (gfc_symbol *sym)
{
- int dimension, codimension, pointer, allocatable, target, optional;
+ int dimension, codimension, pointer, allocatable, target;
symbol_attribute attr;
- gfc_ref *ref;
- gfc_symbol *sym;
- gfc_component *comp;
- bool has_inquiry_part;
-
- if (expr->expr_type != EXPR_VARIABLE
- && expr->expr_type != EXPR_FUNCTION
- && !(expr->expr_type == EXPR_NULL && expr->ts.type != BT_UNKNOWN))
-gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
- sym = expr->symtree->n.sym;
attr = sym->attr;
- optional = attr.optional;
if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived)
{
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Utilisation de la méthode de nullification pour nullifier un pointeur
https://gcc.gnu.org/g:b68e4d2ef22d8fe82d628a320c6577d1d0a946dd
commit b68e4d2ef22d8fe82d628a320c6577d1d0a946dd
Author: Mikael Morin
Date: Wed Dec 18 19:04:41 2024 +0100
Utilisation de la méthode de nullification pour nullifier un pointeur
Correction régression modifiable_p
Correction dump
Ajout assertion
Correction assertion même type
Diff:
---
gcc/fortran/trans-array.cc | 96 ++---
gcc/fortran/trans-array.h | 1 +
gcc/fortran/trans-expr.cc | 35 -
gcc/testsuite/gfortran.dg/class_allocate_14.f90 | 2 +-
4 files changed, 106 insertions(+), 28 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index cdbff27d82ca..4c237b561aa6 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -545,9 +545,9 @@ gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree
desc,
static int
-get_type_info (const gfc_typespec &ts)
+get_type_info (const bt &type)
{
- switch (ts.type)
+ switch (type)
{
case BT_INTEGER:
case BT_LOGICAL:
@@ -558,7 +558,7 @@ get_type_info (const gfc_typespec &ts)
case BT_CLASS:
case BT_VOID:
case BT_UNSIGNED:
- return ts.type;
+ return type;
case BT_PROCEDURE:
case BT_ASSUMED:
@@ -613,11 +613,34 @@ get_size_info (gfc_typespec &ts)
}
-class init_info
+class modify_info
{
public:
+ virtual bool is_initialization () const { return false; }
virtual bool initialize_data () const { return false; }
virtual tree get_data_value () const { return NULL_TREE; }
+};
+
+class nullification : public modify_info
+{
+ virtual bool initialize_data () const { return true; }
+ virtual tree get_data_value () const { return null_pointer_node; }
+ /*
+private:
+ gfc_typespec &ts;
+
+public:
+ null_init(gfc_typespec &arg_ts) : ts(arg_ts) { }
+ virtual bool initialize_data () const { return true; }
+ virtual tree get_data_value () const { return null_pointer_node; }
+ virtual gfc_typespec *get_type () const { return &ts; }
+ */
+};
+
+class init_info : public modify_info
+{
+public:
+ virtual bool is_initialization () const { return true; }
virtual gfc_typespec *get_type () const { return nullptr; }
};
@@ -638,13 +661,13 @@ public:
}
};
-class nullification : public init_info
+class null_init : public init_info
{
private:
gfc_typespec &ts;
public:
- nullification(gfc_typespec &arg_ts) : ts(arg_ts) { }
+ null_init(gfc_typespec &arg_ts) : ts(arg_ts) { }
virtual bool initialize_data () const { return true; }
virtual tree get_data_value () const { return null_pointer_node; }
virtual gfc_typespec *get_type () const { return &ts; }
@@ -700,13 +723,12 @@ build_dtype (gfc_typespec &ts, int rank, const
symbol_attribute &,
CONSTRUCTOR_APPEND_ELT (v, rank_field, rank_val);
}
- if (type_info->type != BT_CLASS)
-{
- 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));
- CONSTRUCTOR_APPEND_ELT (v, type_info_field, type_info_val);
-}
+ 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));
+ CONSTRUCTOR_APPEND_ELT (v, type_info_field, type_info_val);
return build_constructor (type, v);
}
@@ -715,8 +737,8 @@ build_dtype (gfc_typespec &ts, int rank, const
symbol_attribute &,
/* Build a null array descriptor constructor. */
vec *
-get_descriptor_init (tree type, gfc_typespec &ts, int rank,
-const symbol_attribute &attr, const init_info &init)
+get_descriptor_init (tree type, gfc_typespec *ts, int rank,
+const symbol_attribute *attr, const modify_info &init)
{
vec *v = nullptr;
@@ -732,11 +754,15 @@ get_descriptor_init (tree type, gfc_typespec &ts, int
rank,
CONSTRUCTOR_APPEND_ELT (v, data_field, data_value);
}
- tree dtype_field = gfc_advance_chain (fields, DTYPE_FIELD);
- tree dtype_value = build_dtype (ts, rank, attr, init);
- CONSTRUCTOR_APPEND_ELT (v, dtype_field, dtype_value);
+ if (init.is_initialization ())
+{
+ tree dtype_field = gfc_advance_chain (fields, DTYPE_FIELD);
+ tree dtype_value = build_dtype (*ts, rank, *attr,
+ static_cast (init));
+ CONSTRUCTOR_APPEND_ELT (v, dtype_field, dtype_value);
+}
- if (flag_coarray == GFC_FCOARRAY_LIB && attr.codimension)
+ if (flag_coarray == GFC_FCOARRAY_LIB && attr->codimension)
{
/* Declare the variable static so its array descriptor stays present
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation gfc_conv_remap_descriptor
https://gcc.gnu.org/g:7ed00263a569c00bf6bf52ea343e677b873e0e2f
commit 7ed00263a569c00bf6bf52ea343e677b873e0e2f
Author: Mikael Morin
Date: Sat Jan 4 21:36:13 2025 +0100
Factorisation gfc_conv_remap_descriptor
Correction régression pointer_remapping_5
Diff:
---
gcc/fortran/trans-array.cc | 119 +++
gcc/fortran/trans-expr.cc | 124 +++--
gcc/fortran/trans.h| 2 +
3 files changed, 129 insertions(+), 116 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 5d56a12ebf71..898930634ad1 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1332,6 +1332,125 @@ gfc_conv_shift_descriptor (stmtblock_t *block, tree
desc,
}
+void
+gfc_conv_remap_descriptor (stmtblock_t *block, tree dest, tree src,
+ int src_rank, const gfc_array_spec &as)
+{
+ int dest_rank = gfc_descriptor_rank (dest);
+
+ /* Set dtype. */
+ tree dtype = gfc_conv_descriptor_dtype (dest);
+ tree tmp = gfc_get_dtype (TREE_TYPE (src));
+ gfc_add_modify (block, dtype, tmp);
+
+ /* Copy data pointer. */
+ tree data = gfc_conv_descriptor_data_get (src);
+ gfc_conv_descriptor_data_set (block, dest, data);
+
+ /* Copy the span. */
+ tree span;
+ if (VAR_P (src)
+ && GFC_DECL_PTR_ARRAY_P (src))
+span = gfc_conv_descriptor_span_get (src);
+ else
+{
+ tmp = TREE_TYPE (src);
+ tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
+ span = fold_convert (gfc_array_index_type, tmp);
+}
+ gfc_conv_descriptor_span_set (block, dest, span);
+
+ /* Copy offset but adjust it such that it would correspond
+ to a lbound of zero. */
+ if (src_rank == -1)
+gfc_conv_descriptor_offset_set (block, dest,
+ gfc_index_zero_node);
+ else
+{
+ tree offs = gfc_conv_descriptor_offset_get (src);
+ for (int dim = 0; dim < src_rank; ++dim)
+ {
+ tree stride = gfc_conv_descriptor_stride_get (src,
+ gfc_rank_cst[dim]);
+ tree lbound = gfc_conv_descriptor_lbound_get (src,
+ gfc_rank_cst[dim]);
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+gfc_array_index_type, stride,
+lbound);
+ offs = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, offs, tmp);
+ }
+ gfc_conv_descriptor_offset_set (block, dest, offs);
+}
+ /* Set the bounds as declared for the LHS and calculate strides as
+ well as another offset update accordingly. */
+ tree stride = gfc_conv_descriptor_stride_get (src,
+ gfc_rank_cst[0]);
+ for (int dim = 0; dim < dest_rank; ++dim)
+{
+ gfc_se lower_se;
+ gfc_se upper_se;
+
+ gcc_assert (as.lower[dim] && as.upper[dim]);
+
+ /* Convert declared bounds. */
+ gfc_init_se (&lower_se, NULL);
+ gfc_init_se (&upper_se, NULL);
+ gfc_conv_expr (&lower_se, as.lower[dim]);
+ gfc_conv_expr (&upper_se, as.upper[dim]);
+
+ gfc_add_block_to_block (block, &lower_se.pre);
+ gfc_add_block_to_block (block, &upper_se.pre);
+
+ tree lbound = fold_convert (gfc_array_index_type, lower_se.expr);
+ tree ubound = fold_convert (gfc_array_index_type, upper_se.expr);
+
+ lbound = gfc_evaluate_now (lbound, block);
+ ubound = gfc_evaluate_now (ubound, block);
+
+ gfc_add_block_to_block (block, &lower_se.post);
+ gfc_add_block_to_block (block, &upper_se.post);
+
+ /* Set bounds in descriptor. */
+ gfc_conv_descriptor_lbound_set (block, dest,
+ gfc_rank_cst[dim], lbound);
+ gfc_conv_descriptor_ubound_set (block, dest,
+ gfc_rank_cst[dim], ubound);
+
+ /* Set stride. */
+ stride = gfc_evaluate_now (stride, block);
+ gfc_conv_descriptor_stride_set (block, dest,
+ gfc_rank_cst[dim], stride);
+
+ /* Update offset. */
+ tree offs = gfc_conv_descriptor_offset_get (dest);
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+gfc_array_index_type, lbound, stride);
+ offs = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, offs, tmp);
+ offs = gfc_evaluate_now (offs, block);
+ gfc_conv_descriptor_offset_set (block, dest, offs);
+
+ /* Update stride. */
+ tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ stride = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, stride, tmp);
+}
+}
+
+
+void
+gfc_conv_remap_descriptor (stmtblock_t *block, tree dest, tree src,
+ int src_rank, const gfc_array_ref &ar)
+{
+ g
[gcc] Created branch 'mikael/heads/refactor_descriptor_v01' in namespace 'refs/users'
The branch 'mikael/heads/refactor_descriptor_v01' was created in namespace 'refs/users' pointing to: deac09f715c2... Correction régression alloc_comp_constructor_1.f90
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Sauvegarde modifs
https://gcc.gnu.org/g:e3de44455296f04e014dad8c9efaef858384cfac
commit e3de44455296f04e014dad8c9efaef858384cfac
Author: Mikael Morin
Date: Sat Dec 7 22:22:10 2024 +0100
Sauvegarde modifs
Annulation suppression else
Correction assertions
Initialisation vptr
Non initialisation elem_len pour les conteneurs de classe
Mise à jour class_allocatable_14
Diff:
---
gcc/fortran/trans-array.cc | 52 ++
gcc/fortran/trans-array.h | 2 +
gcc/fortran/trans-decl.cc | 58 +
gcc/testsuite/gfortran.dg/class_allocate_14.f90 | 2 +-
4 files changed, 66 insertions(+), 48 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 268de211cd66..d15576adde10 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -734,6 +734,58 @@ gfc_build_null_descriptor (tree type, gfc_typespec &ts,
}
+tree
+gfc_build_default_class_descriptor (tree type, gfc_typespec &ts)
+{
+ vec *v = nullptr;
+
+ tree fields = TYPE_FIELDS (type);
+
+#define CLASS_DATA_FIELD 0
+#define CLASS_VPTR_FIELD 1
+
+ tree data_field = gfc_advance_chain (fields, CLASS_DATA_FIELD);
+ tree data_type = TREE_TYPE (data_field);
+
+ gcc_assert (ts.type == BT_CLASS);
+ tree data_value;
+ if (ts.u.derived->components->attr.dimension
+ || (ts.u.derived->components->attr.codimension
+ && flag_coarray != GFC_FCOARRAY_LIB))
+{
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (data_type));
+ data_value = gfc_build_null_descriptor (data_type,
+ ts,
+
ts.u.derived->components->as->rank,
+ ts.u.derived->components->attr);
+}
+ else
+{
+ gcc_assert (POINTER_TYPE_P (data_type));
+ data_value = fold_convert (data_type, null_pointer_node);
+}
+ CONSTRUCTOR_APPEND_ELT (v, data_field, data_value);
+
+ tree vptr_field = gfc_advance_chain (fields, CLASS_VPTR_FIELD);
+
+ tree vptr_value;
+ if (ts.u.derived->attr.unlimited_polymorphic)
+vptr_value = fold_convert (TREE_TYPE (vptr_field), null_pointer_node);
+ else
+{
+ gfc_symbol *vsym = gfc_find_derived_vtab (ts.u.derived);
+ tree vsym_decl = gfc_get_symbol_decl (vsym);
+ vptr_value = gfc_build_addr_expr (nullptr, vsym_decl);
+}
+ CONSTRUCTOR_APPEND_ELT (v, vptr_field, vptr_value);
+
+#undef CLASS_DATA_FIELD
+#undef CLASS_VPTR_FIELD
+
+ return build_constructor (type, v);
+}
+
+
void
gfc_clear_descriptor (gfc_expr *var_ref, gfc_se &var)
{
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 1bb3294b0749..63a77d562a7b 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -140,6 +140,8 @@ void gfc_set_delta (gfc_loopinfo *);
void gfc_conv_resolve_dependencies (gfc_loopinfo *, gfc_ss *, gfc_ss *);
/* Build a null array descriptor constructor. */
tree gfc_build_null_descriptor (tree);
+tree gfc_build_default_class_descriptor (tree, gfc_typespec &);
+void gfc_clear_descriptor (stmtblock_t *block, gfc_symbol *sym, tree
descriptor);
/* Get a single array element. */
void gfc_conv_array_ref (gfc_se *, gfc_array_ref *, gfc_expr *, locus *);
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 4ae22a5584d0..dad15858fa6a 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -4780,16 +4780,14 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym,
gfc_wrapped_block * block)
else if (proc_sym == proc_sym->result && IS_CLASS_ARRAY (proc_sym))
{
/* Nullify explicit return class arrays on entry. */
- tree type;
tmp = get_proc_result (proc_sym);
- if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
- {
- gfc_start_block (&init);
- tmp = gfc_class_data_get (tmp);
- type = TREE_TYPE (gfc_conv_descriptor_data_get (tmp));
- gfc_conv_descriptor_data_set (&init, tmp, build_int_cst (type, 0));
- gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
- }
+ if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+ {
+ gfc_start_block (&init);
+ tmp = gfc_class_data_get (tmp);
+ gfc_clear_descriptor (&init, proc_sym, tmp);
+ gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+ }
}
@@ -4931,48 +4929,13 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym,
gfc_wrapped_block * block)
}
}
- if (sym->attr.pointer && sym->attr.dimension
- && sym->attr.save == SAVE_NONE
- && !sym->attr.use_assoc
- && !sym->attr.host_assoc
- && !sym->attr.dummy
- && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)))
- {
- gfc_init_block (&tmpblock);
- gfc_conv_descriptor_span_set (&tmpblock, sym->backend_decl,
-
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Extraction fonction fcncall_realloc_result
https://gcc.gnu.org/g:ed6fee22d9c29ebee21ce323726fb14cfb8d6ed1
commit ed6fee22d9c29ebee21ce323726fb14cfb8d6ed1
Author: Mikael Morin
Date: Thu Jan 9 21:38:39 2025 +0100
Extraction fonction fcncall_realloc_result
Correction variable inutilisée
Correction régression coarray dummy_3
Correction régression dummy_3
Diff:
---
gcc/fortran/trans-array.cc | 64 ++
gcc/fortran/trans-array.h | 1 +
gcc/fortran/trans-expr.cc | 52 +++--
3 files changed, 80 insertions(+), 37 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 898930634ad1..7d43a8c000d3 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1451,6 +1451,70 @@ gfc_conv_remap_descriptor (stmtblock_t *block, tree
dest, tree src,
}
+class conditional_lb
+{
+ tree cond;
+public:
+ conditional_lb (tree arg_cond)
+: cond (arg_cond) { }
+
+ tree lower_bound (tree src, int n) const {
+tree lbound = gfc_conv_descriptor_lbound_get (src, gfc_rank_cst[n]);
+lbound = fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type, cond,
+ gfc_index_one_node, lbound);
+return lbound;
+ }
+};
+
+
+static void
+gfc_conv_shift_descriptor (stmtblock_t *block, tree dest, tree src,
+ int rank, const conditional_lb &lb)
+{
+ tree tmp = gfc_conv_descriptor_data_get (src);
+ gfc_conv_descriptor_data_set (block, dest, tmp);
+
+ tree offset = gfc_index_zero_node;
+ for (int n = 0 ; n < rank; n++)
+{
+ tree lbound;
+
+ lbound = lb.lower_bound (dest, n);
+ lbound = gfc_evaluate_now (lbound, block);
+
+ tmp = gfc_conv_descriptor_ubound_get (src, gfc_rank_cst[n]);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+gfc_array_index_type, tmp, lbound);
+ gfc_conv_descriptor_lbound_set (block, dest,
+ gfc_rank_cst[n], lbound);
+ gfc_conv_descriptor_ubound_set (block, dest,
+ gfc_rank_cst[n], tmp);
+
+ /* Set stride and accumulate the offset. */
+ tmp = gfc_conv_descriptor_stride_get (src, gfc_rank_cst[n]);
+ gfc_conv_descriptor_stride_set (block, dest,
+ gfc_rank_cst[n], tmp);
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+gfc_array_index_type, lbound, tmp);
+ offset = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, offset, tmp);
+ offset = gfc_evaluate_now (offset, block);
+}
+
+ gfc_conv_descriptor_offset_set (block, dest, offset);
+}
+
+
+void
+gfc_conv_shift_descriptor (stmtblock_t *block, tree dest, tree src,
+ int rank, tree zero_cond)
+{
+ gfc_conv_shift_descriptor (block, dest, src, rank,
+conditional_lb (zero_cond));
+}
+
+
static bool
keep_descriptor_lower_bound (gfc_expr *e)
{
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 8df55c2c00a5..571322ae11ff 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -216,6 +216,7 @@ tree gfc_get_cfi_dim_sm (tree, tree);
/* Shift lower bound of descriptor, updating ubound and offset. */
void gfc_conv_shift_descriptor_lbound (stmtblock_t*, tree, int, tree);
void gfc_conv_shift_descriptor (stmtblock_t*, tree, const gfc_array_ref &);
+void gfc_conv_shift_descriptor (stmtblock_t*, tree, tree, int, tree);
/* Add pre-loop scalarization code for intrinsic functions which require
special handling. */
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index c50b1e05cdbd..77e8a55af457 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -832,6 +832,9 @@ gfc_get_vptr_from_expr (tree expr)
int
gfc_descriptor_rank (tree descriptor)
{
+ if (TREE_TYPE (descriptor) != NULL_TREE)
+return GFC_TYPE_ARRAY_RANK (TREE_TYPE (descriptor));
+
tree dim = gfc_get_descriptor_dimension (descriptor);
tree dim_type = TREE_TYPE (dim);
gcc_assert (TREE_CODE (dim_type) == ARRAY_TYPE);
@@ -916,8 +919,17 @@ gfc_class_array_data_assign (stmtblock_t *block, tree
lhs_desc, tree rhs_desc,
type = TREE_TYPE (tmp);
else
{
- gcc_assert (TREE_TYPE (tmp) == TREE_TYPE (tmp2));
- type = TREE_TYPE (tmp);
+ int corank = GFC_TYPE_ARRAY_CORANK (TREE_TYPE (lhs_desc));
+ int corank2 = GFC_TYPE_ARRAY_CORANK (TREE_TYPE (rhs_desc));
+ if (corank > 0 && corank2 == 0)
+ type = TREE_TYPE (tmp2);
+ else if (corank2 > 0 && corank == 0)
+ type = TREE_TYPE (tmp);
+ else
+ {
+ gcc_assert (TREE_TYPE (tmp) == TREE_TYPE (tmp2));
+ type = TREE_TYPE (tmp);
+ }
}
tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
@@ -11595,7 +11607,6 @@ fcncall_realloc_result (g
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Appel méthode shift descriptor dans gfc_trans_pointer_assignment
https://gcc.gnu.org/g:ecdc8da68c9d5419d4c0e6ec9b1b3278076cbdf0
commit ecdc8da68c9d5419d4c0e6ec9b1b3278076cbdf0
Author: Mikael Morin
Date: Tue Dec 17 22:37:18 2024 +0100
Appel méthode shift descriptor dans gfc_trans_pointer_assignment
Diff:
---
gcc/fortran/trans-array.cc | 129 +++--
gcc/fortran/trans-array.h | 1 +
gcc/fortran/trans-expr.cc | 28 +-
3 files changed, 129 insertions(+), 29 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 2fdd15962e49..cdbff27d82ca 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1151,13 +1151,136 @@ gfc_conv_shift_descriptor_lbound (stmtblock_t* block,
tree desc,
}
+class lb_info
+{
+public:
+ virtual gfc_expr *lower_bound (int dim) const = 0;
+};
+
+
+class unset_lb : public lb_info
+{
+public:
+ virtual gfc_expr *lower_bound (int) const { return nullptr; }
+};
+
+
+class defined_lb : public lb_info
+{
+ int rank;
+ gfc_expr * const * lower_bounds;
+
+public:
+ defined_lb (int arg_rank, gfc_expr * const
arg_lower_bounds[GFC_MAX_DIMENSIONS])
+: rank(arg_rank), lower_bounds(arg_lower_bounds) { }
+ virtual gfc_expr *lower_bound (int dim) const { return lower_bounds[dim]; }
+};
+
+
static void
-conv_shift_descriptor (stmtblock_t* block, tree desc, int rank)
+conv_shift_descriptor (stmtblock_t *block, tree desc, int rank,
+ const lb_info &info)
{
/* Apply a shift of the lbound when supplied. */
for (int dim = 0; dim < rank; ++dim)
-gfc_conv_shift_descriptor_lbound (block, desc, dim,
- gfc_index_one_node);
+{
+ gfc_expr *lb_expr = info.lower_bound(dim);
+
+ tree lower_bound;
+ if (lb_expr == nullptr)
+ lower_bound = gfc_index_one_node;
+ else
+ {
+ gfc_se lb_se;
+
+ gfc_init_se (&lb_se, nullptr);
+ gfc_conv_expr (&lb_se, lb_expr);
+
+ gfc_add_block_to_block (block, &lb_se.pre);
+ tree lb_var = gfc_create_var (TREE_TYPE (lb_se.expr), "lower_bound");
+ gfc_add_modify (block, lb_var, lb_se.expr);
+ gfc_add_block_to_block (block, &lb_se.post);
+
+ lower_bound = lb_var;
+ }
+
+ gfc_conv_shift_descriptor_lbound (block, desc, dim, lower_bound);
+}
+}
+
+
+static void
+conv_shift_descriptor (stmtblock_t* block, tree desc, int rank)
+{
+ conv_shift_descriptor (block, desc, rank, unset_lb ());
+}
+
+
+static void
+conv_shift_descriptor (stmtblock_t *block, tree desc, int rank,
+ gfc_expr * const lower_bounds[GFC_MAX_DIMENSIONS])
+{
+ conv_shift_descriptor (block, desc, rank, defined_lb (rank, lower_bounds));
+}
+
+
+static void
+conv_shift_descriptor (stmtblock_t *block, tree desc,
+ const gfc_array_spec &as)
+{
+ conv_shift_descriptor (block, desc, as.rank, as.lower);
+}
+
+
+static void
+set_type (array_type &type, array_type value)
+{
+ gcc_assert (type == AS_UNKNOWN || type == value);
+ type = value;
+}
+
+
+static void
+array_ref_to_array_spec (const gfc_array_ref &ref, gfc_array_spec &spec)
+{
+ spec.rank = ref.dimen;
+ spec.corank = ref.codimen;
+
+ spec.type = AS_UNKNOWN;
+ spec.cotype = AS_ASSUMED_SIZE;
+
+ for (int dim = 0; dim < spec.rank + spec.corank; dim++)
+switch (ref.dimen_type[dim])
+ {
+ case DIMEN_ELEMENT:
+ spec.upper[dim] = ref.start[dim];
+ set_type (spec.type, AS_EXPLICIT);
+ break;
+
+ case DIMEN_RANGE:
+ spec.lower[dim] = ref.start[dim];
+ spec.upper[dim] = ref.end[dim];
+ if (spec.upper[dim] == nullptr)
+ set_type (spec.type, AS_DEFERRED);
+ else
+ set_type (spec.type, AS_EXPLICIT);
+ break;
+
+ default:
+ break;
+ }
+}
+
+
+void
+gfc_conv_shift_descriptor (stmtblock_t *block, tree desc,
+ const gfc_array_ref &ar)
+{
+ gfc_array_spec as;
+
+ array_ref_to_array_spec (ar, as);
+
+ conv_shift_descriptor (block, desc, as);
}
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 17e3d08fdba0..3b05a2eb197a 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -214,6 +214,7 @@ tree gfc_get_cfi_dim_sm (tree, tree);
/* Shift lower bound of descriptor, updating ubound and offset. */
void gfc_conv_shift_descriptor_lbound (stmtblock_t*, tree, int, tree);
+void gfc_conv_shift_descriptor (stmtblock_t*, tree, const gfc_array_ref &);
/* Add pre-loop scalarization code for intrinsic functions which require
special handling. */
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index e8b229d853e3..1de4a73974d6 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -11180,32 +11180,8 @@ gfc_trans_pointer_assignment (gfc_expr * expr1,
gfc_expr * expr2)
}
}
else
- {
- /* Bounds remapping. Just shift the lower bounds. */
-
-
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Introduction gfc_copy_sequence_descriptor
https://gcc.gnu.org/g:6d1a550acfb35381deea5afbd424a7e79852f5b1
commit 6d1a550acfb35381deea5afbd424a7e79852f5b1
Author: Mikael Morin
Date: Tue Dec 31 15:27:35 2024 +0100
Introduction gfc_copy_sequence_descriptor
Correction régression sizeof_6
Diff:
---
gcc/fortran/trans-array.cc | 39 ++-
gcc/fortran/trans-expr.cc | 44
gcc/fortran/trans.h| 1 +
3 files changed, 59 insertions(+), 25 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 4c237b561aa6..5d56a12ebf71 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -9901,32 +9901,21 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr,
bool g77,
if (maybe_shift && !keep_descriptor_lower_bound (expr))
conv_shift_descriptor (&block, se->expr, expr->rank);
+ bool assumed_rank_fsym;
+ if (fsym
+ && ((fsym->ts.type == BT_CLASS
+ && CLASS_DATA (fsym)->as
+ && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
+ || (fsym->ts.type != BT_CLASS
+ && fsym->as
+ && fsym->as->type == AS_ASSUMED_RANK)))
+ assumed_rank_fsym = true;
+ else
+ assumed_rank_fsym = false;
+
tmp = gfc_class_data_get (ctree);
- if (expr->rank > 1 && CLASS_DATA (fsym)->as->rank != expr->rank
- && CLASS_DATA (fsym)->as->type == AS_EXPLICIT && !no_pack)
- {
- tree arr = gfc_create_var (TREE_TYPE (tmp), "parm");
- gfc_conv_descriptor_data_set (&block, arr,
- gfc_conv_descriptor_data_get (
- se->expr));
- gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
- gfc_index_zero_node);
- gfc_conv_descriptor_ubound_set (
- &block, arr, gfc_index_zero_node,
- gfc_conv_descriptor_size (se->expr, expr->rank));
- gfc_conv_descriptor_stride_set (
- &block, arr, gfc_index_zero_node,
- gfc_conv_descriptor_stride_get (se->expr, gfc_index_zero_node));
- gfc_add_modify (&block, gfc_conv_descriptor_dtype (arr),
- gfc_conv_descriptor_dtype (se->expr));
- gfc_add_modify (&block, gfc_conv_descriptor_rank (arr),
- build_int_cst (signed_char_type_node, 1));
- gfc_conv_descriptor_span_set (&block, arr,
- gfc_conv_descriptor_span_get (arr));
- gfc_conv_descriptor_offset_set (&block, arr, gfc_index_zero_node);
- se->expr = arr;
- }
- gfc_class_array_data_assign (&block, tmp, se->expr, true);
+ gfc_copy_sequence_descriptor (block, tmp, se->expr,
+ assumed_rank_fsym);
/* Handle optional. */
if (fsym && fsym->attr.optional && sym && sym->attr.optional)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 003754cdad6f..5dff9692f0ba 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -846,6 +846,50 @@ descriptor_rank (tree descriptor)
}
+void
+gfc_copy_sequence_descriptor (stmtblock_t &block, tree lhs_desc, tree rhs_desc,
+ bool assumed_rank_lhs)
+{
+ int lhs_rank = descriptor_rank (lhs_desc);
+ int rhs_rank = descriptor_rank (rhs_desc);
+ tree desc;
+
+ if (assumed_rank_lhs || lhs_rank == rhs_rank)
+desc = rhs_desc;
+ else
+{
+ tree arr = gfc_create_var (TREE_TYPE (lhs_desc), "parm");
+ gfc_conv_descriptor_data_set (&block, arr,
+ gfc_conv_descriptor_data_get (rhs_desc));
+ gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
+ gfc_index_zero_node);
+ tree size = gfc_conv_descriptor_size (rhs_desc, rhs_rank);
+ gfc_conv_descriptor_ubound_set (&block, arr, gfc_index_zero_node, size);
+ gfc_conv_descriptor_stride_set (
+ &block, arr, gfc_index_zero_node,
+ gfc_conv_descriptor_stride_get (rhs_desc, gfc_index_zero_node));
+ for (int i = 1; i < lhs_rank; i++)
+ {
+ gfc_conv_descriptor_lbound_set (&block, arr, gfc_rank_cst[i],
+ gfc_index_zero_node);
+ gfc_conv_descriptor_ubound_set (&block, arr, gfc_rank_cst[i],
+ gfc_index_zero_node);
+ gfc_conv_descriptor_stride_set (&block, arr, gfc_rank_cst[i], size);
+ }
+ gfc_add_modify (&block, gfc_conv_descriptor_dtype (arr),
+ gfc_conv_descriptor_dtype (rhs_desc));
+ gfc_add_modify (&block, gfc_conv_descriptor_rank (arr),
+ build_int_cst (signed_cha
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation shift descriptor
https://gcc.gnu.org/g:7818e31b1ca1ea4796040325332a850765ef9fdd
commit 7818e31b1ca1ea4796040325332a850765ef9fdd
Author: Mikael Morin
Date: Thu Jan 16 14:51:42 2025 +0100
Factorisation shift descriptor
Diff:
---
gcc/fortran/trans-expr.cc | 7 +--
1 file changed, 1 insertion(+), 6 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 77e8a55af457..b7d1e3df0613 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1219,7 +1219,6 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
tree ctree;
tree var;
tree tmp;
- int dim;
bool unlimited_poly;
unlimited_poly = class_ts.type == BT_CLASS
@@ -1287,11 +1286,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
/* Array references with vector subscripts and non-variable
expressions
need be converted to a one-based descriptor. */
if (e->expr_type != EXPR_VARIABLE)
- {
- for (dim = 0; dim < e->rank; ++dim)
- gfc_conv_shift_descriptor_lbound (&parmse->pre, parmse->expr,
- dim, gfc_index_one_node);
- }
+ gfc_conv_shift_descriptor (&parmse->pre, parmse->expr, e->rank);
if (class_ts.u.derived->components->as->rank != e->rank)
{
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation gfc_conv_expr_descriptor
https://gcc.gnu.org/g:d607595f1f4f4566776000aeedfd4d0bb3ce4b9b
commit d607595f1f4f4566776000aeedfd4d0bb3ce4b9b
Author: Mikael Morin
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)
+ {
+
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation set descriptor with shape
https://gcc.gnu.org/g:c3a50c1a8cb83384345d3dc3530fbb9b830d6e85
commit c3a50c1a8cb83384345d3dc3530fbb9b830d6e85
Author: Mikael Morin
Date: Fri Jan 17 21:46:27 2025 +0100
Factorisation set descriptor with shape
Diff:
---
gcc/fortran/trans-array.cc | 78 ++
gcc/fortran/trans-array.h | 2 ++
gcc/fortran/trans-intrinsic.cc | 76 +++-
3 files changed, 85 insertions(+), 71 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 88a2509a5246..b05f69fdd874 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1566,6 +1566,84 @@ copy_descriptor (stmtblock_t *block, tree dest, tree src,
gfc_conv_descriptor_span_set (block, dest, tmp);
}
+
+void
+gfc_set_descriptor_with_shape (stmtblock_t *block, tree desc,
+ tree ptr, gfc_expr *shape,
+ locus *where)
+{
+ /* Set the span field. */
+ tree tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
+ tmp = fold_convert (gfc_array_index_type, tmp);
+ gfc_conv_descriptor_span_set (block, desc, tmp);
+
+ /* Set data value, dtype, and offset. */
+ tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
+ gfc_conv_descriptor_data_set (block, desc, fold_convert (tmp, ptr));
+ gfc_add_modify (block, gfc_conv_descriptor_dtype (desc),
+ gfc_get_dtype (TREE_TYPE (desc)));
+
+ /* Start scalarization of the bounds, using the shape argument. */
+
+ gfc_ss *shape_ss = gfc_walk_expr (shape);
+ gcc_assert (shape_ss != gfc_ss_terminator);
+ gfc_se shapese;
+ gfc_init_se (&shapese, NULL);
+
+ gfc_loopinfo loop;
+ gfc_init_loopinfo (&loop);
+ gfc_add_ss_to_loop (&loop, shape_ss);
+ gfc_conv_ss_startstride (&loop);
+ gfc_conv_loop_setup (&loop, where);
+ gfc_mark_ss_chain_used (shape_ss, 1);
+
+ gfc_copy_loopinfo_to_se (&shapese, &loop);
+ shapese.ss = shape_ss;
+
+ tree stride = gfc_create_var (gfc_array_index_type, "stride");
+ tree offset = gfc_create_var (gfc_array_index_type, "offset");
+ gfc_add_modify (block, stride, gfc_index_one_node);
+ gfc_add_modify (block, offset, gfc_index_zero_node);
+
+ /* Loop body. */
+ stmtblock_t body;
+ gfc_start_scalarized_body (&loop, &body);
+
+ tree dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ loop.loopvar[0], loop.from[0]);
+
+ /* Set bounds and stride. */
+ gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node);
+ gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
+
+ gfc_conv_expr (&shapese, shape);
+ gfc_add_block_to_block (&body, &shapese.pre);
+ gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr);
+ gfc_add_block_to_block (&body, &shapese.post);
+
+ /* Calculate offset. */
+ gfc_add_modify (&body, offset,
+ fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, offset, stride));
+ /* Update stride. */
+ gfc_add_modify (&body, stride,
+ fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, stride,
+ fold_convert (gfc_array_index_type,
+shapese.expr)));
+ /* Finish scalarization loop. */
+ gfc_trans_scalarizing_loops (&loop, &body);
+ gfc_add_block_to_block (block, &loop.pre);
+ gfc_add_block_to_block (block, &loop.post);
+ gfc_cleanup_loop (&loop);
+
+ gfc_add_modify (block, offset,
+ fold_build1_loc (input_location, NEGATE_EXPR,
+ gfc_array_index_type, offset));
+ gfc_conv_descriptor_offset_set (block, desc, offset);
+}
+
+
/* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
void
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 3f39845c898f..05ea68d531ac 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -145,6 +145,8 @@ void gfc_clear_descriptor (stmtblock_t *block, gfc_symbol
*, tree);
void gfc_nullify_descriptor (stmtblock_t *block, gfc_expr *, tree);
void gfc_clear_descriptor (stmtblock_t *block, gfc_symbol *, gfc_expr *, tree);
void gfc_set_scalar_descriptor (stmtblock_t *block, tree, gfc_symbol *,
gfc_expr *, tree);
+void gfc_set_descriptor_with_shape (stmtblock_t *, tree, tree,
+ gfc_expr *, locus *);
/* Get a single array element. */
void gfc_conv_array_ref (gfc_se *, gfc_array_ref *, gfc_expr *, locus *);
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index b6900d734afd..5d77f3d768a6 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -10482,11 +10482,8 @@ conv_isocbinding_subroutine (gfc_code *code)
gfc_se se;
gfc_se cptrse;
gfc_se fptrse;
- gfc_se shapese;
- gfc_ss *shape_ss;
- tree desc, dim, tmp, stride, offset;
- stmtbl
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation initialisation subarray_descriptor
https://gcc.gnu.org/g:41e38348a930505eacdc9386c9fce31a40bdbdb2
commit 41e38348a930505eacdc9386c9fce31a40bdbdb2
Author: Mikael Morin
Date: Tue Jan 21 18:44:41 2025 +0100
Factorisation initialisation subarray_descriptor
Diff:
---
gcc/fortran/trans-expr.cc | 151 --
1 file changed, 78 insertions(+), 73 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index b7d1e3df0613..65b6cd8a4642 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -9418,17 +9418,90 @@ gfc_trans_subarray_assign (tree dest, gfc_component *
cm, gfc_expr * expr)
}
+static void
+set_subarray_descriptor (stmtblock_t *block, tree desc, tree value,
+gfc_expr *value_expr, gfc_expr *conv_arg)
+{
+ if (value_expr->expr_type != EXPR_VARIABLE)
+gfc_conv_descriptor_data_set (block, value,
+ null_pointer_node);
+
+ /* Obtain the array spec of full array references. */
+ gfc_array_spec *as;
+ if (conv_arg)
+as = gfc_get_full_arrayspec_from_expr (conv_arg);
+ else
+as = gfc_get_full_arrayspec_from_expr (value_expr);
+
+ /* Shift the lbound and ubound of temporaries to being unity,
+ rather than zero, based. Always calculate the offset. */
+ tree offset = gfc_conv_descriptor_offset_get (desc);
+ gfc_add_modify (block, offset, gfc_index_zero_node);
+ tree tmp2 = gfc_create_var (gfc_array_index_type, NULL);
+
+ for (int n = 0; n < value_expr->rank; n++)
+{
+ tree span;
+ tree lbound;
+
+ /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
+TODO It looks as if gfc_conv_expr_descriptor should return
+the correct bounds and that the following should not be
+necessary. This would simplify gfc_conv_intrinsic_bound
+as well. */
+ if (as && as->lower[n])
+ {
+ gfc_se lbse;
+ gfc_init_se (&lbse, NULL);
+ gfc_conv_expr (&lbse, as->lower[n]);
+ gfc_add_block_to_block (block, &lbse.pre);
+ lbound = gfc_evaluate_now (lbse.expr, block);
+ }
+ else if (as && conv_arg)
+ {
+ tree tmp = gfc_get_symbol_decl (conv_arg->symtree->n.sym);
+ lbound = gfc_conv_descriptor_lbound_get (tmp,
+ gfc_rank_cst[n]);
+ }
+ else if (as)
+ lbound = gfc_conv_descriptor_lbound_get (desc,
+ gfc_rank_cst[n]);
+ else
+ lbound = gfc_index_one_node;
+
+ lbound = fold_convert (gfc_array_index_type, lbound);
+
+ /* Shift the bounds and set the offset accordingly. */
+ tree tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
+ span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ tmp, gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+span, lbound);
+ gfc_conv_descriptor_ubound_set (block, desc,
+ gfc_rank_cst[n], tmp);
+ gfc_conv_descriptor_lbound_set (block, desc,
+ gfc_rank_cst[n], lbound);
+
+ tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+gfc_conv_descriptor_lbound_get (desc,
+gfc_rank_cst[n]),
+gfc_conv_descriptor_stride_get (desc,
+gfc_rank_cst[n]));
+ gfc_add_modify (block, tmp2, tmp);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+offset, tmp2);
+ gfc_conv_descriptor_offset_set (block, desc, tmp);
+}
+}
+
+
static tree
gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
gfc_expr * expr)
{
gfc_se se;
stmtblock_t block;
- tree offset;
- int n;
tree tmp;
- tree tmp2;
- gfc_array_spec *as;
gfc_expr *arg = NULL;
gfc_start_block (&block);
@@ -9489,10 +9562,6 @@ gfc_trans_alloc_subarray_assign (tree dest,
gfc_component * cm,
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &se.post);
- if (expr->expr_type != EXPR_VARIABLE)
-gfc_conv_descriptor_data_set (&block, se.expr,
- null_pointer_node);
-
/* We need to know if the argument of a conversion function is a
variable, so that the correct lower bound can be used. */
if (expr->expr_type == EXPR_FUNCTION
@@ -9502,71 +9571,7 @@ gfc_trans_alloc_subarray_assign (tree dest,
gfc_component * cm,
&& expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
arg = expr->value.function.actual->expr;
- /* Obtain the array spec of full array references. */
- if (arg)
-as = gfc_get_full_arrayspec_from_expr (arg);
- else
-a
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation set_contiguous_array
https://gcc.gnu.org/g:ccb2dcc879e6c3debbd0e010cfc394cfde504fbc
commit ccb2dcc879e6c3debbd0e010cfc394cfde504fbc
Author: Mikael Morin
Date: Fri Jan 17 17:25:59 2025 +0100
Factorisation set_contiguous_array
Diff:
---
gcc/fortran/trans-array.cc | 57 +++---
1 file changed, 29 insertions(+), 28 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 4f066680dff0..76668d8a3ef1 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -10685,6 +10685,23 @@ gfc_caf_is_dealloc_only (int caf_mode)
}
+static void
+set_contiguous_array (stmtblock_t *block, tree desc, tree size, tree data_ptr)
+{
+ gfc_add_modify (block, gfc_conv_descriptor_dtype (desc),
+ gfc_get_dtype_rank_type (1, TREE_TYPE (desc)));
+ gfc_conv_descriptor_lbound_set (block, desc,
+ gfc_index_zero_node,
+ gfc_index_one_node);
+ gfc_conv_descriptor_stride_set (block, desc,
+ gfc_index_zero_node,
+ gfc_index_one_node);
+ gfc_conv_descriptor_ubound_set (block, desc,
+ gfc_index_zero_node, size);
+ gfc_conv_descriptor_data_set (block, desc, data_ptr);
+}
+
+
/* Recursively traverse an object of derived type, generating code to
deallocate, nullify or copy allocatable components. This is the work horse
function for the functions named in this enum. */
@@ -10945,32 +10962,6 @@ structure_alloc_comps (gfc_symbol * der_type, tree
decl, tree dest,
ubound = build_int_cst (gfc_array_index_type, 1);
}
- /* Treat strings like arrays. Or the other way around, do not
- * generate an additional array layer for scalar components. */
- if (attr->dimension || c->ts.type == BT_CHARACTER)
- {
- cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
-&ubound, 1,
-GFC_ARRAY_ALLOCATABLE, false);
-
- cdesc = gfc_create_var (cdesc, "cdesc");
- DECL_ARTIFICIAL (cdesc) = 1;
-
- gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
- gfc_get_dtype_rank_type (1, tmp));
- gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
- gfc_index_zero_node,
- gfc_index_one_node);
- gfc_conv_descriptor_stride_set (&tmpblock, cdesc,
- gfc_index_zero_node,
- gfc_index_one_node);
- gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
- gfc_index_zero_node, ubound);
- }
- else
- /* Prevent warning. */
- cdesc = NULL_TREE;
-
if (attr->dimension)
{
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
@@ -10993,13 +10984,23 @@ structure_alloc_comps (gfc_symbol * der_type, tree
decl, tree dest,
gfc_add_block_to_block (&tmpblock, &se.pre);
}
+ /* Treat strings like arrays. Or the other way around, do not
+ * generate an additional array layer for scalar components. */
if (attr->dimension || c->ts.type == BT_CHARACTER)
- gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp);
+ {
+ cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
+&ubound, 1,
+GFC_ARRAY_ALLOCATABLE, false);
+
+ cdesc = gfc_create_var (cdesc, "cdesc");
+ DECL_ARTIFICIAL (cdesc) = 1;
+
+ set_contiguous_array (&tmpblock, cdesc, ubound, comp);
+ }
else
cdesc = comp;
tree fndecl;
-
fndecl = build_call_expr_loc (input_location,
gfor_fndecl_co_broadcast, 5,
gfc_build_addr_expr
(pvoid_type_node,cdesc),
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Essai suppression unlimited_polymorphic
https://gcc.gnu.org/g:bd3573d2425487de1c1d165e86d63ff83037c584
commit bd3573d2425487de1c1d165e86d63ff83037c584
Author: Mikael Morin
Date: Thu Jan 16 20:45:34 2025 +0100
Essai suppression unlimited_polymorphic
Diff:
---
gcc/fortran/trans-array.cc | 13 -
gcc/fortran/trans.h| 3 ---
2 files changed, 4 insertions(+), 12 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index bf11689cf3dd..4f066680dff0 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -9019,7 +9019,7 @@ 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)
+ bool data_needed, bool subref)
{
int ndim = info->ref ? info->ref->u.ar.dimen : rank;
@@ -9044,9 +9044,7 @@ set_descriptor (stmtblock_t *block, tree dest, tree src,
gfc_expr *src_expr,
/* 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)
+ if (src_expr->ts.type == BT_ASSUMED)
{
tree tmp2 = src;
if (DECL_LANG_SPECIFIC (tmp2) && GFC_DECL_SAVED_DESCRIPTOR (tmp2))
@@ -9056,7 +9054,7 @@ set_descriptor (stmtblock_t *block, tree dest, tree src,
gfc_expr *src_expr,
dtype = gfc_conv_descriptor_dtype (tmp2);
}
else
-dtype = gfc_get_dtype (TREE_TYPE (dest));
+dtype = gfc_get_dtype (TREE_TYPE (src), &rank);
gfc_add_modify (block, tmp, dtype);
/* The 1st element in the section. */
@@ -9254,9 +9252,6 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
expr = expr->value.function.actual->expr;
}
- if (!se->direct_byref)
-se->unlimited_polymorphic = UNLIMITED_POLY (expr);
-
/* Special case things we know we can pass easily. */
switch (expr->expr_type)
{
@@ -9660,7 +9655,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
}
set_descriptor (&loop.pre, parm, desc, expr, loop.dimen, codim,
- ss, info, loop.from, loop.to, se->unlimited_polymorphic,
+ ss, info, loop.from, loop.to,
!se->data_not_needed, subref_array_target);
desc = parm;
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 098fb07c1483..197dea0a18a6 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -61,9 +61,6 @@ typedef struct gfc_se
the reference to the class object here. */
tree class_container;
- /* Whether expr is a reference to an unlimited polymorphic object. */
- unsigned unlimited_polymorphic:1;
-
/* If set gfc_conv_variable will return an expression for the array
descriptor. When set, want_pointer should also be set.
If not set scalarizing variables will be substituted. */
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Refactor conv_shift_descriptor
https://gcc.gnu.org/g:a6d12d1f09654a5d3038b6042e645dd9da4c84a5
commit a6d12d1f09654a5d3038b6042e645dd9da4c84a5
Author: Mikael Morin
Date: Thu Jan 16 15:28:38 2025 +0100
Refactor conv_shift_descriptor
Correction régressions
Correction régression gfc_conv_expr_descriptor
Diff:
---
gcc/fortran/trans-array.cc | 31 +--
gcc/fortran/trans-array.h | 1 -
2 files changed, 17 insertions(+), 15 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index ecdaad3f9575..bf11689cf3dd 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1165,16 +1165,15 @@ gfc_build_null_descriptor (tree type)
/* Modify a descriptor such that the lbound of a given dimension is the value
specified. This also updates ubound and offset accordingly. */
-void
-gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
- int dim, tree new_lbound)
+static void
+conv_shift_descriptor_lbound (stmtblock_t* block, tree desc, int dim,
+ tree new_lbound, tree offset)
{
- tree offs, ubound, lbound, stride;
+ tree ubound, lbound, stride;
tree diff, offs_diff;
new_lbound = fold_convert (gfc_array_index_type, new_lbound);
- offs = gfc_conv_descriptor_offset_get (desc);
lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
@@ -1190,9 +1189,9 @@ gfc_conv_shift_descriptor_lbound (stmtblock_t* block,
tree desc,
gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
diff, stride);
- offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- offs, offs_diff);
- gfc_conv_descriptor_offset_set (block, desc, offs);
+ tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ offset, offs_diff);
+ gfc_add_modify (block, offset, tmp);
/* Finally set lbound to value we want. */
gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
@@ -1229,6 +1228,10 @@ static void
conv_shift_descriptor (stmtblock_t *block, tree desc, int rank,
const lb_info &info)
{
+ tree tmp = gfc_conv_descriptor_offset_get (desc);
+ tree offset_var = gfc_create_var (TREE_TYPE (tmp), "offset");
+ gfc_add_modify (block, offset_var, tmp);
+
/* Apply a shift of the lbound when supplied. */
for (int dim = 0; dim < rank; ++dim)
{
@@ -1252,8 +1255,10 @@ conv_shift_descriptor (stmtblock_t *block, tree desc,
int rank,
lower_bound = lb_var;
}
- gfc_conv_shift_descriptor_lbound (block, desc, dim, lower_bound);
+ conv_shift_descriptor_lbound (block, desc, dim, lower_bound, offset_var);
}
+
+ gfc_conv_descriptor_offset_set (block, desc, offset_var);
}
@@ -9225,7 +9230,6 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
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)
@@ -9251,7 +9255,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
}
if (!se->direct_byref)
-unlimited_polymorphic = UNLIMITED_POLY (expr);
+se->unlimited_polymorphic = UNLIMITED_POLY (expr);
/* Special case things we know we can pass easily. */
switch (expr->expr_type)
@@ -9655,9 +9659,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
gfc_get_array_span (desc, expr)));
}
-
- set_descriptor (&se->pre, parm, desc, expr, loop.dimen, codim,
- ss, info, loop.from, loop.to, unlimited_polymorphic,
+ set_descriptor (&loop.pre, parm, desc, expr, loop.dimen, codim,
+ ss, info, loop.from, loop.to, se->unlimited_polymorphic,
!se->data_not_needed, subref_array_target);
desc = parm;
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 378afb9617a3..3f39845c898f 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -214,7 +214,6 @@ tree gfc_get_cfi_dim_sm (tree, tree);
/* Shift lower bound of descriptor, updating ubound and offset. */
-void gfc_conv_shift_descriptor_lbound (stmtblock_t*, tree, int, tree);
void gfc_conv_shift_descriptor (stmtblock_t*, tree, const gfc_array_ref &);
void gfc_conv_shift_descriptor (stmtblock_t*, tree, int);
void gfc_conv_shift_descriptor (stmtblock_t*, tree, tree, int, tree);
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation copie gfc_conv_expr_descriptor
https://gcc.gnu.org/g:82413c99dc41ba8b632e751540ba26d97ea67ceb
commit 82413c99dc41ba8b632e751540ba26d97ea67ceb
Author: Mikael Morin
Date: Wed Jan 15 17:51:21 2025 +0100
Factorisation copie gfc_conv_expr_descriptor
Diff:
---
gcc/fortran/trans-array.cc | 37 ++---
1 file changed, 22 insertions(+), 15 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 7d43a8c000d3..097a9a0d860a 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -8989,6 +8989,26 @@ is_explicit_coarray (gfc_expr *expr)
return cas && cas->cotype == AS_EXPLICIT;
}
+
+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);
+}
+
/* 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
@@ -9123,21 +9143,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
if (full && !transposed_dims (ss))
{
if (se->direct_byref && !se->byref_noassign)
- {
- /* Copy the descriptor for pointer assignments. */
- gfc_add_modify (&se->pre, se->expr, desc);
-
- /* Add any offsets from subreferences. */
- gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
- subref_array_target, expr);
-
- /* and set the span field. */
- if (ss_info->expr->ts.type == BT_CHARACTER)
- tmp = gfc_conv_descriptor_span_get (desc);
- else
- tmp = gfc_get_array_span (desc, expr);
- gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
- }
+ copy_descriptor (&se->pre, se->expr, desc, expr,
+subref_array_target);
else if (se->want_pointer)
{
/* We pass full arrays directly. This means that pointers and
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Refactoring gfc_conv_descriptor_sm_get.
https://gcc.gnu.org/g:7d9a5b709d1f2400ea62c334bff7c9d4436a687c
commit 7d9a5b709d1f2400ea62c334bff7c9d4436a687c
Author: Mikael Morin
Date: Wed Jan 22 21:59:46 2025 +0100
Refactoring gfc_conv_descriptor_sm_get.
Diff:
---
gcc/fortran/trans-array.cc | 11 +++
gcc/fortran/trans-array.h | 1 +
gcc/fortran/trans-expr.cc | 4 +---
3 files changed, 13 insertions(+), 3 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 7357626be9a5..4d08a862c5be 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -589,6 +589,17 @@ gfc_conv_descriptor_extent_get (tree desc, tree dim)
}
+tree
+gfc_conv_descriptor_sm_get (tree desc, tree dim)
+{
+ tree stride = gfc_conv_descriptor_stride_get (desc, dim);
+ tree span = gfc_conv_descriptor_span_get (desc);
+
+ return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ stride, span);
+}
+
+
static int
get_type_info (const bt &type)
{
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 1d694989b4c3..296a8052dd73 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -195,6 +195,7 @@ tree gfc_conv_descriptor_stride_get (tree, tree);
tree gfc_conv_descriptor_lbound_get (tree, tree);
tree gfc_conv_descriptor_ubound_get (tree, tree);
tree gfc_conv_descriptor_extent_get (tree, tree);
+tree gfc_conv_descriptor_sm_get (tree, tree);
tree gfc_conv_descriptor_token (tree);
void gfc_conv_descriptor_data_set (stmtblock_t *, tree, tree);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 84111f5e3d3d..6daa4a727f12 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6262,9 +6262,7 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr
*e, gfc_symbol *fsym)
tmp = gfc_conv_descriptor_extent_get (gfc, idx);
gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp);
/* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */
- tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
-gfc_conv_descriptor_stride_get (gfc, idx),
-gfc_conv_descriptor_span_get (gfc));
+ tmp = gfc_conv_descriptor_sm_get (gfc, idx);
gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
/* Generate loop. */
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Déplacement gfc_copy_sequence_descriptor
https://gcc.gnu.org/g:d29279433aa2fbcd57c06a7a9ca84e09a35c5bba
commit d29279433aa2fbcd57c06a7a9ca84e09a35c5bba
Author: Mikael Morin
Date: Thu Jan 30 21:21:39 2025 +0100
Déplacement gfc_copy_sequence_descriptor
Correction erreur compil'
Diff:
---
gcc/fortran/trans-array.cc | 64 ++
gcc/fortran/trans-array.h | 1 +
gcc/fortran/trans-expr.cc | 64 --
gcc/fortran/trans.h| 1 -
4 files changed, 65 insertions(+), 65 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index a1fb41fc9354..455c9bcd76cc 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1835,6 +1835,70 @@ gfc_set_descriptor_from_scalar (stmtblock_t *block, tree
desc, tree scalar,
gfc_conv_descriptor_data_set (block, desc, tmp);
}
+int
+gfc_descriptor_rank (tree descriptor)
+{
+ if (TREE_TYPE (descriptor) != NULL_TREE)
+return GFC_TYPE_ARRAY_RANK (TREE_TYPE (descriptor));
+
+ tree dim = gfc_get_descriptor_dimension (descriptor);
+ tree dim_type = TREE_TYPE (dim);
+ gcc_assert (TREE_CODE (dim_type) == ARRAY_TYPE);
+ tree idx_type = TYPE_DOMAIN (dim_type);
+ gcc_assert (TREE_CODE (idx_type) == INTEGER_TYPE);
+ gcc_assert (integer_zerop (TYPE_MIN_VALUE (idx_type)));
+ tree idx_max = TYPE_MAX_VALUE (idx_type);
+ if (idx_max == NULL_TREE)
+return GFC_MAX_DIMENSIONS;
+ wide_int max = wi::to_wide (idx_max);
+ return max.to_shwi () + 1;
+}
+
+
+void
+gfc_copy_sequence_descriptor (stmtblock_t &block, tree lhs_desc, tree rhs_desc,
+ bool assumed_rank_lhs)
+{
+ int lhs_rank = gfc_descriptor_rank (lhs_desc);
+ int rhs_rank = gfc_descriptor_rank (rhs_desc);
+ tree desc;
+
+ if (assumed_rank_lhs || lhs_rank == rhs_rank)
+desc = rhs_desc;
+ else
+{
+ tree arr = gfc_create_var (TREE_TYPE (lhs_desc), "parm");
+ gfc_conv_descriptor_data_set (&block, arr,
+ gfc_conv_descriptor_data_get (rhs_desc));
+ gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
+ gfc_index_zero_node);
+ tree size = gfc_conv_descriptor_size (rhs_desc, rhs_rank);
+ gfc_conv_descriptor_ubound_set (&block, arr, gfc_index_zero_node, size);
+ gfc_conv_descriptor_stride_set (
+ &block, arr, gfc_index_zero_node,
+ gfc_conv_descriptor_stride_get (rhs_desc, gfc_index_zero_node));
+ for (int i = 1; i < lhs_rank; i++)
+ {
+ gfc_conv_descriptor_lbound_set (&block, arr, gfc_rank_cst[i],
+ gfc_index_zero_node);
+ gfc_conv_descriptor_ubound_set (&block, arr, gfc_rank_cst[i],
+ gfc_index_zero_node);
+ gfc_conv_descriptor_stride_set (&block, arr, gfc_rank_cst[i], size);
+ }
+ gfc_add_modify (&block, gfc_conv_descriptor_dtype (arr),
+ gfc_conv_descriptor_dtype (rhs_desc));
+ gfc_add_modify (&block, gfc_conv_descriptor_rank (arr),
+ build_int_cst (signed_char_type_node, lhs_rank));
+ gfc_conv_descriptor_span_set (&block, arr,
+ gfc_conv_descriptor_span_get (arr));
+ gfc_conv_descriptor_offset_set (&block, arr, gfc_index_zero_node);
+ desc = arr;
+}
+
+ gfc_class_array_data_assign (&block, lhs_desc, desc, true);
+}
+
+
/* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 691231f66903..124020a53858 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -150,6 +150,7 @@ void gfc_set_descriptor_with_shape (stmtblock_t *, tree,
tree,
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);
+void gfc_copy_sequence_descriptor (stmtblock_t &, tree, tree, bool);
/* Get a single array element. */
void gfc_conv_array_ref (gfc_se *, gfc_array_ref *, gfc_expr *, locus *);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 2ece9d369d80..205c49949626 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -800,70 +800,6 @@ gfc_get_vptr_from_expr (tree expr)
}
-int
-gfc_descriptor_rank (tree descriptor)
-{
- if (TREE_TYPE (descriptor) != NULL_TREE)
-return GFC_TYPE_ARRAY_RANK (TREE_TYPE (descriptor));
-
- tree dim = gfc_get_descriptor_dimension (descriptor);
- tree dim_type = TREE_TYPE (dim);
- gcc_assert (TREE_CODE (dim_type) == ARRAY_TYPE);
- tree idx_type = TYPE_DOMAIN (dim_type);
- gcc_assert (TREE_CODE (idx_type) == INTEGER_TYPE);
- gcc_assert (integer_zerop (TYPE_MIN_VALUE (idx_type)));
- tree idx_max = TYPE_MAX_VALUE (idx_type);
- if (idx_max == NULL_TREE)
-return GFC_MAX_DIMENSIONS;
- wide_int max = wi::to_wide
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Déplacement gfc_set_gfc_from_cfi
https://gcc.gnu.org/g:47b6338824d5cf0658bd91e24bd956dcf2bfaca3
commit 47b6338824d5cf0658bd91e24bd956dcf2bfaca3
Author: Mikael Morin
Date: Thu Jan 30 21:27:40 2025 +0100
Déplacement gfc_set_gfc_from_cfi
Correction compil'
Diff:
---
gcc/fortran/trans-array.cc | 258 +
gcc/fortran/trans-array.h | 3 +
gcc/fortran/trans-expr.cc | 218 --
gcc/fortran/trans.h| 3 -
4 files changed, 241 insertions(+), 241 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 455c9bcd76cc..d6e7c9829ff2 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1466,6 +1466,26 @@ gfc_conv_shift_descriptor_subarray (stmtblock_t *block,
tree desc,
}
+int
+gfc_descriptor_rank (tree descriptor)
+{
+ if (TREE_TYPE (descriptor) != NULL_TREE)
+return GFC_TYPE_ARRAY_RANK (TREE_TYPE (descriptor));
+
+ tree dim = gfc_get_descriptor_dimension (descriptor);
+ tree dim_type = TREE_TYPE (dim);
+ gcc_assert (TREE_CODE (dim_type) == ARRAY_TYPE);
+ tree idx_type = TYPE_DOMAIN (dim_type);
+ gcc_assert (TREE_CODE (idx_type) == INTEGER_TYPE);
+ gcc_assert (integer_zerop (TYPE_MIN_VALUE (idx_type)));
+ tree idx_max = TYPE_MAX_VALUE (idx_type);
+ if (idx_max == NULL_TREE)
+return GFC_MAX_DIMENSIONS;
+ wide_int max = wi::to_wide (idx_max);
+ return max.to_shwi () + 1;
+}
+
+
void
gfc_conv_remap_descriptor (stmtblock_t *block, tree dest, tree src,
int src_rank, const gfc_array_spec &as)
@@ -1835,26 +1855,6 @@ gfc_set_descriptor_from_scalar (stmtblock_t *block, tree
desc, tree scalar,
gfc_conv_descriptor_data_set (block, desc, tmp);
}
-int
-gfc_descriptor_rank (tree descriptor)
-{
- if (TREE_TYPE (descriptor) != NULL_TREE)
-return GFC_TYPE_ARRAY_RANK (TREE_TYPE (descriptor));
-
- tree dim = gfc_get_descriptor_dimension (descriptor);
- tree dim_type = TREE_TYPE (dim);
- gcc_assert (TREE_CODE (dim_type) == ARRAY_TYPE);
- tree idx_type = TYPE_DOMAIN (dim_type);
- gcc_assert (TREE_CODE (idx_type) == INTEGER_TYPE);
- gcc_assert (integer_zerop (TYPE_MIN_VALUE (idx_type)));
- tree idx_max = TYPE_MAX_VALUE (idx_type);
- if (idx_max == NULL_TREE)
-return GFC_MAX_DIMENSIONS;
- wide_int max = wi::to_wide (idx_max);
- return max.to_shwi () + 1;
-}
-
-
void
gfc_copy_sequence_descriptor (stmtblock_t &block, tree lhs_desc, tree rhs_desc,
bool assumed_rank_lhs)
@@ -1899,6 +1899,224 @@ gfc_copy_sequence_descriptor (stmtblock_t &block, tree
lhs_desc, tree rhs_desc,
}
+void
+gfc_set_gfc_from_cfi (stmtblock_t *unconditional_block,
+ stmtblock_t *conditional_block, tree gfc, tree cfi,
+ tree rank, gfc_symbol *gfc_sym,
+ bool init_static, bool contiguous_gfc, bool
contiguous_cfi)
+{
+ tree tmp = gfc_get_cfi_desc_base_addr (cfi);
+ gfc_conv_descriptor_data_set (unconditional_block, gfc, tmp);
+
+ if (init_static)
+{
+ /* gfc->dtype = ... (from declaration, not from cfi). */
+ tree etype = gfc_get_element_type (TREE_TYPE (gfc));
+ gfc_add_modify (unconditional_block, gfc_conv_descriptor_dtype (gfc),
+ gfc_get_dtype_rank_type (gfc_sym->as->rank, etype));
+
+ if (gfc_sym->as->type == AS_ASSUMED_RANK)
+ gfc_add_modify (unconditional_block,
+ gfc_conv_descriptor_rank (gfc), rank);
+}
+
+ if (gfc_sym && gfc_sym->ts.type == BT_ASSUMED)
+{
+ /* For type(*), take elem_len + dtype.type from the actual argument. */
+ gfc_add_modify (unconditional_block, gfc_conv_descriptor_elem_len (gfc),
+ gfc_get_cfi_desc_elem_len (cfi));
+ tree cond;
+ tree ctype = gfc_get_cfi_desc_type (cfi);
+ ctype = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (ctype),
+ ctype, build_int_cst (TREE_TYPE (ctype),
+CFI_type_mask));
+ tree type = gfc_conv_descriptor_type (gfc);
+
+ /* if (CFI_type_cptr) BT_VOID else BT_UNKNOWN */
+ /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
ctype,
+ build_int_cst (TREE_TYPE (ctype), CFI_type_cptr));
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
+build_int_cst (TREE_TYPE (type), BT_VOID));
+ tree tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+ type,
+ build_int_cst (TREE_TYPE (type),
BT_UNKNOWN));
+ tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+ tmp, tmp2);
+ /* if (CFI_type_struct) BT_DERIVED else < tmp2 > */
+ cond = fold_build2_loc (input_location, EQ_
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation initialisation depuis cfi
https://gcc.gnu.org/g:1392f13442685eacd23ee09a10daccbaf00481ec
commit 1392f13442685eacd23ee09a10daccbaf00481ec
Author: Mikael Morin
Date: Fri Jan 24 16:01:58 2025 +0100
Factorisation initialisation depuis cfi
Correction régression contiguous-2.f90
Correction regression contiguous-2.f90
Correction régression bind-c-contiguous-1.f90
Diff:
---
gcc/fortran/trans-decl.cc | 220 --
gcc/fortran/trans-expr.cc | 209 ---
gcc/fortran/trans.h | 2 +
3 files changed, 194 insertions(+), 237 deletions(-)
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index dad15858fa6a..baa36e88bf15 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -7009,7 +7009,7 @@ gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t
*finally,
stmtblock_t block;
gfc_init_block (&block);
tree cfi = build_fold_indirect_ref_loc (input_location, cfi_desc);
- tree idx, etype, tmp, tmp2, size_var = NULL_TREE, rank = NULL_TREE;
+ tree idx, tmp, tmp2, size_var = NULL_TREE, rank = NULL_TREE;
bool do_copy_inout = false;
/* When allocatable + intent out, free the cfi descriptor. */
@@ -7201,106 +7201,10 @@ gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t
*finally,
goto done;
}
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
-{
- /* gfc->dtype = ... (from declaration, not from cfi). */
- etype = gfc_get_element_type (TREE_TYPE (gfc_desc));
- gfc_add_modify (&block, gfc_conv_descriptor_dtype (gfc_desc),
- gfc_get_dtype_rank_type (sym->as->rank, etype));
- /* gfc->data = cfi->base_addr. */
- gfc_conv_descriptor_data_set (&block, gfc_desc,
- gfc_get_cfi_desc_base_addr (cfi));
-}
-
- if (sym->ts.type == BT_ASSUMED)
-{
- /* For type(*), take elem_len + dtype.type from the actual argument. */
- gfc_add_modify (&block, gfc_conv_descriptor_elem_len (gfc_desc),
- gfc_get_cfi_desc_elem_len (cfi));
- tree cond;
- tree ctype = gfc_get_cfi_desc_type (cfi);
- ctype = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (ctype),
- ctype, build_int_cst (TREE_TYPE (ctype),
-CFI_type_mask));
- tree type = gfc_conv_descriptor_type (gfc_desc);
-
- /* if (CFI_type_cptr) BT_VOID else BT_UNKNOWN */
- /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
ctype,
- build_int_cst (TREE_TYPE (ctype), CFI_type_cptr));
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
-build_int_cst (TREE_TYPE (type), BT_VOID));
- tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
- type,
- build_int_cst (TREE_TYPE (type), BT_UNKNOWN));
- tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
- /* if (CFI_type_struct) BT_DERIVED else < tmp2 > */
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
ctype,
- build_int_cst (TREE_TYPE (ctype),
-CFI_type_struct));
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
-build_int_cst (TREE_TYPE (type), BT_DERIVED));
- tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
- /* if (CFI_type_Character) BT_CHARACTER else < tmp2 > */
- /* Note: this is kind=1, CFI_type_ucs4_char is handled in the 'else if'
-before (see below, as generated bottom up). */
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
ctype,
- build_int_cst (TREE_TYPE (ctype),
- CFI_type_Character));
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
-build_int_cst (TREE_TYPE (type), BT_CHARACTER));
- tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
- /* if (CFI_type_ucs4_char) BT_CHARACTER else < tmp2 > */
- /* Note: gfc->elem_len = cfi->elem_len/4. */
- /* However, assuming that CFI_type_ucs4_char cannot be recovered, leave
-gfc->elem_len == cfi->elem_len, which helps with operations which use
-sizeof() in Fortran and cfi->elem_len in C. */
- tmp = gfc_get_cfi_desc_type (cfi);
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
- build_int_cst (TREE_TYPE (tmp),
-
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] utilisation booléen allocatable
https://gcc.gnu.org/g:84be5a435f2a78f8a9ab0bdf5b693a1e0c6b6fd5
commit 84be5a435f2a78f8a9ab0bdf5b693a1e0c6b6fd5
Author: Mikael Morin
Date: Thu Jan 23 21:38:24 2025 +0100
utilisation booléen allocatable
Diff:
---
gcc/fortran/trans-expr.cc | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 95b168fe76a8..518a5a127cf0 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -5938,12 +5938,12 @@ set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
static void
set_gfc_from_cfi (stmtblock_t *block, tree gfc, tree cfi, tree rank,
- gfc_symbol *c_sym)
+ bool allocatable)
{
tree tmp = gfc_get_cfi_desc_base_addr (cfi);
gfc_conv_descriptor_data_set (block, gfc, tmp);
- if (c_sym->attr.allocatable)
+ if (allocatable)
{
/* gfc->span = cfi->elem_len. */
tmp = fold_convert (gfc_array_index_type,
@@ -6396,7 +6396,7 @@ done:
tmp = gfc_get_cfi_desc_base_addr (cfi);
gfc_conv_descriptor_data_set (&block, gfc, tmp);
- set_gfc_from_cfi (&block2, gfc, cfi, rank, fsym);
+ set_gfc_from_cfi (&block2, gfc, cfi, rank, fsym->attr.allocatable);
}
if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation set_descriptor_from_scalar dans conv_class_to_class
https://gcc.gnu.org/g:60fb6b7d916d2d309ca305c8848baefe06ae06c6
commit 60fb6b7d916d2d309ca305c8848baefe06ae06c6
Author: Mikael Morin
Date: Tue Jan 28 21:03:24 2025 +0100
Factorisation set_descriptor_from_scalar dans conv_class_to_class
Correction régression associate_66
Correction régression PR100040.f90
Diff:
---
gcc/fortran/trans-expr.cc | 34 ++
1 file changed, 22 insertions(+), 12 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index a5cd0a452d81..6afb344245f2 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -172,6 +172,27 @@ gfc_conv_null_array_descriptor (gfc_se *se, gfc_symbol
*sym, gfc_expr *expr)
}
+void
+set_descriptor_from_scalar (stmtblock_t *block, tree desc, tree scalar,
+ gfc_expr *scalar_expr)
+{
+ tree type = get_scalar_to_descriptor_type (scalar,
+gfc_expr_attr (scalar_expr));
+ if (POINTER_TYPE_P (type))
+type = TREE_TYPE (type);
+
+ tree dtype_val = gfc_get_dtype (type);
+ tree dtype_ref = gfc_conv_descriptor_dtype (desc);
+ gfc_add_modify (block, dtype_ref, dtype_val);
+
+ tree tmp = gfc_class_data_get (scalar);
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+
+ gfc_conv_descriptor_data_set (block, desc, tmp);
+}
+
+
tree
gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
{
@@ -1434,18 +1455,7 @@ 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)
- {
- tree type = get_scalar_to_descriptor_type (parmse->expr,
-gfc_expr_attr (e));
- gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
- gfc_get_dtype (type));
-
- tmp = gfc_class_data_get (parmse->expr);
- if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
-
- gfc_conv_descriptor_data_set (&block, ctree, tmp);
- }
+ set_descriptor_from_scalar (&block, ctree, parmse->expr, e);
else
gfc_class_array_data_assign (&block, ctree, parmse->expr, false);
}
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Update dump match count
https://gcc.gnu.org/g:08384499e15f84f573c888267a125e6ae15cd904
commit 08384499e15f84f573c888267a125e6ae15cd904
Author: Mikael Morin
Date: Thu Jan 30 16:53:48 2025 +0100
Update dump match count
Diff:
---
gcc/testsuite/gfortran.dg/coarray_collectives_18.f90 | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_18.f90
b/gcc/testsuite/gfortran.dg/coarray_collectives_18.f90
index c83899de0e5b..a1f2a76ff73e 100644
--- a/gcc/testsuite/gfortran.dg/coarray_collectives_18.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_collectives_18.f90
@@ -33,5 +33,5 @@ end program
! This lead to access to non exsitant memory in opencoarrays.
! In single image mode just checking for reduced number of
! descriptors is possible, i.e., execute always works.
-! { dg-final { scan-tree-dump-times "desc\\.\[0-9\]+" 12 "original" } }
+! { dg-final { scan-tree-dump-times "desc\\.\[0-9\]+" 10 "original" } }
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation set_descriptor_from_scalar conv_derived_to_class
https://gcc.gnu.org/g:c3d8cf0e081de45c9a2f5d2d80ff8675f5e4614a
commit c3d8cf0e081de45c9a2f5d2d80ff8675f5e4614a
Author: Mikael Morin
Date: Wed Jan 29 18:22:29 2025 +0100
Factorisation set_descriptor_from_scalar conv_derived_to_class
Diff:
---
gcc/fortran/trans-expr.cc | 42 +++---
1 file changed, 23 insertions(+), 19 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 6afb344245f2..091e1417faed 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -174,7 +174,8 @@ gfc_conv_null_array_descriptor (gfc_se *se, gfc_symbol
*sym, gfc_expr *expr)
void
set_descriptor_from_scalar (stmtblock_t *block, tree desc, tree scalar,
- gfc_expr *scalar_expr)
+ gfc_expr *scalar_expr, bool is_class,
+ tree cond_optional)
{
tree type = get_scalar_to_descriptor_type (scalar,
gfc_expr_attr (scalar_expr));
@@ -185,9 +186,22 @@ set_descriptor_from_scalar (stmtblock_t *block, tree desc,
tree scalar,
tree dtype_ref = gfc_conv_descriptor_dtype (desc);
gfc_add_modify (block, dtype_ref, dtype_val);
- tree tmp = gfc_class_data_get (scalar);
- if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
-tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+ tree tmp;
+ if (is_class)
+{
+ tmp = gfc_class_data_get (scalar);
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+}
+ else if (cond_optional)
+{
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (scalar),
+ cond_optional, scalar,
+ fold_convert (TREE_TYPE (scalar),
+ null_pointer_node));
+}
+ else
+tmp = scalar;
gfc_conv_descriptor_data_set (block, desc, tmp);
}
@@ -1067,20 +1081,9 @@ 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)
- {
- tree type;
- type = get_scalar_to_descriptor_type (parmse->expr,
- gfc_expr_attr (e));
- gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
- gfc_get_dtype (type));
- if (optional)
- parmse->expr = build3_loc (input_location, COND_EXPR,
- TREE_TYPE (parmse->expr),
- cond_optional, parmse->expr,
- fold_convert (TREE_TYPE
(parmse->expr),
-null_pointer_node));
- gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
- }
+ set_descriptor_from_scalar (&parmse->pre, ctree,
+ parmse->expr, e, false,
+ cond_optional);
else
{
tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
@@ -1455,7 +1458,8 @@ 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)
- set_descriptor_from_scalar (&block, ctree, parmse->expr, e);
+ set_descriptor_from_scalar (&block, ctree, parmse->expr, e,
+ true, NULL_TREE);
else
gfc_class_array_data_assign (&block, ctree, parmse->expr, false);
}
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Renseignement token par gfc_set_descriptor_from_scalar.
https://gcc.gnu.org/g:96c395b57efb83588e592fca055aac91794c0919
commit 96c395b57efb83588e592fca055aac91794c0919
Author: Mikael Morin
Date: Wed Feb 5 15:12:25 2025 +0100
Renseignement token par gfc_set_descriptor_from_scalar.
Diff:
---
gcc/fortran/trans-array.cc | 27 ---
gcc/fortran/trans-array.h | 2 +-
gcc/fortran/trans-expr.cc | 15 +++
3 files changed, 32 insertions(+), 12 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 531281049646..c09b9bdab155 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -682,6 +682,7 @@ public:
virtual bool set_span () const { return false; }
virtual bool set_token () const { return true; }
virtual tree get_data_value () const { return NULL_TREE; }
+ virtual tree get_caf_token () const { return null_pointer_node; }
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); }
};
@@ -751,22 +752,24 @@ private:
bool initialisation;
gfc_typespec *ts;
tree value;
+ tree caf_token;
bool use_tree_type_;
bool clear_token;
tree get_elt_type () const;
public:
scalar_value(gfc_typespec &arg_ts, tree 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) { }
+: initialisation(true), ts(&arg_ts), value(arg_value), caf_token
(NULL_TREE), use_tree_type_ (false), clear_token(true) { }
+ scalar_value(tree arg_value, tree arg_caf_token)
+: initialisation(true), ts(nullptr), value(arg_value), caf_token
(arg_caf_token), 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;
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 bool set_token () const { return clear_token || caf_token !=
NULL_TREE; }
+ virtual tree get_caf_token () const;
virtual bt get_type_type (const gfc_typespec &) const;
virtual tree get_length (gfc_typespec *ts) const;
};
@@ -838,6 +841,16 @@ scalar_value::get_length (gfc_typespec * type_info) const
return size;
}
+tree
+scalar_value::get_caf_token () const
+{
+ if (set_token ()
+ && caf_token != NULL_TREE)
+return caf_token;
+ else
+return modify_info::get_caf_token ();
+}
+
static tree
build_dtype (gfc_typespec *ts, int rank, const symbol_attribute &,
@@ -933,7 +946,7 @@ get_descriptor_init (tree type, gfc_typespec *ts, int rank,
tree token_field = gfc_advance_chain (fields,
CAF_TOKEN_FIELD - (!dim_present));
tree token_value = fold_convert (TREE_TYPE (token_field),
- null_pointer_node);
+ init.get_caf_token ());
CONSTRUCTOR_APPEND_ELT (v, token_field, token_value);
}
@@ -1430,11 +1443,11 @@ 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)
+ symbol_attribute *attr, tree caf_token)
{
init_struct (block, desc,
get_descriptor_init (TREE_TYPE (desc), nullptr, 0, attr,
- scalar_value (scalar)));
+ scalar_value (scalar, caf_token)));
}
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 97cf7f8cb41f..2dad79aa9993 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 *);
+symbol_attribute *, tree = NULL_TREE);
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 39bd7178c3c0..13a1ec1e8fe3 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -883,14 +883,20 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
gfc_symbol *fsym,
/* Now set the data field. */
ctree = gfc_
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Séparation motifs dump assumed_rank_12.f90
https://gcc.gnu.org/g:cd99fadb64da650e93e666dbf2eb7c4b15a6dc5b
commit cd99fadb64da650e93e666dbf2eb7c4b15a6dc5b
Author: Mikael Morin
Date: Wed Feb 5 11:57:09 2025 +0100
Séparation motifs dump assumed_rank_12.f90
Diff:
---
gcc/testsuite/gfortran.dg/assumed_rank_12.f90 | 6 +-
1 file changed, 5 insertions(+), 1 deletion(-)
diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_12.f90
b/gcc/testsuite/gfortran.dg/assumed_rank_12.f90
index 873498f82d76..cacfb7ed52af 100644
--- a/gcc/testsuite/gfortran.dg/assumed_rank_12.f90
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_12.f90
@@ -16,5 +16,9 @@ function f() result(res)
end function f
end
-! { dg-final { scan-tree-dump " = f \\(\\);.*desc.0.dtype = .*;.*desc.0.data =
.void .. D.*;.*sub \\(&desc.0\\);.*D.*= .integer.kind=4. .. desc.0.data;"
"original" } }
+! { dg-final { scan-tree-dump " = f \\(\\);" "original" } }
+! { dg-final { scan-tree-dump "desc.0.dtype = .*;" "original" } }
+! { dg-final { scan-tree-dump "desc.0.data = .void .. D.*;" "original" } }
+! { dg-final { scan-tree-dump "sub \\(&desc.0\\);" "original" } }
+! { dg-final { scan-tree-dump "D.*= .integer.kind=4. .. desc.0.data;"
"original" } }
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation gfc_conv_shift_descriptor
https://gcc.gnu.org/g:5f6c199003762a2572741ff43cf8c64f6940ec13
commit 5f6c199003762a2572741ff43cf8c64f6940ec13
Author: Mikael Morin
Date: Thu Feb 6 17:16:13 2025 +0100
Factorisation gfc_conv_shift_descriptor
Correction compil'
Correction régression allocated_4.f90
Factorisation gfc_conv_shift_descriptor.
Correction régression allocated_4.f90
Modifications mineures
Correction régression bound_10.f90
Diff:
---
gcc/fortran/trans-array.cc | 165 ++---
1 file changed, 81 insertions(+), 84 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index c09b9bdab155..bf965dc68268 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1476,35 +1476,43 @@ gfc_build_null_descriptor (tree type)
specified. This also updates ubound and offset accordingly. */
static void
-conv_shift_descriptor_lbound (stmtblock_t* block, tree desc, int dim,
- tree new_lbound, tree offset)
+conv_shift_descriptor_lbound (stmtblock_t* block, tree from_desc, tree
to_desc, int dim,
+ tree new_lbound, tree offset, bool zero_based)
{
- tree ubound, lbound, stride;
- tree diff, offs_diff;
-
+ /* Set lbound to the value we want. */
new_lbound = fold_convert (gfc_array_index_type, new_lbound);
+ new_lbound = gfc_evaluate_now (new_lbound, block);
+ gfc_conv_descriptor_lbound_set (block, to_desc, gfc_rank_cst[dim],
new_lbound);
- lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
- ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
- stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
+ tree lbound = gfc_conv_descriptor_lbound_get (from_desc, gfc_rank_cst[dim]);
+ tree ubound = gfc_conv_descriptor_ubound_get (from_desc, gfc_rank_cst[dim]);
+ tree stride = gfc_conv_descriptor_stride_get (from_desc, gfc_rank_cst[dim]);
- /* Get difference (new - old) by which to shift stuff. */
- diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- new_lbound, lbound);
+ tree diff;
+ if (zero_based)
+diff = new_lbound;
+ else
+{
+ /* Get difference (new - old) by which to shift stuff. */
+ diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ new_lbound, lbound);
+ diff = gfc_evaluate_now (diff, block);
+}
/* Shift ubound and offset accordingly. This has to be done before
updating the lbound, as they depend on the lbound expression! */
- ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
- ubound, diff);
- gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
- offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- diff, stride);
- tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- offset, offs_diff);
- gfc_add_modify (block, offset, tmp);
+ tree tmp1 = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+ ubound, diff);
+ gfc_conv_descriptor_ubound_set (block, to_desc, gfc_rank_cst[dim], tmp1);
- /* Finally set lbound to value we want. */
- gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
+ tree offs_diff = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
+ diff, stride);
+ tree tmp2 = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
+ offset, offs_diff);
+ gfc_add_modify (block, offset, tmp2);
+
+ if (from_desc != to_desc)
+gfc_conv_descriptor_stride_set (block, to_desc, gfc_rank_cst[dim], stride);
}
@@ -1512,6 +1520,7 @@ class lb_info_base
{
public:
virtual tree lower_bound (stmtblock_t *block, int dim) const = 0;
+ virtual bool zero_based_src () const { return false; }
};
@@ -1572,21 +1581,64 @@ public:
static void
-conv_shift_descriptor (stmtblock_t *block, tree desc, int rank,
+conv_shift_descriptor (stmtblock_t *block, tree src, tree dest, int rank,
const lb_info_base &info)
{
- tree tmp = gfc_conv_descriptor_offset_get (desc);
- tree offset_var = gfc_create_var (TREE_TYPE (tmp), "offset");
- gfc_add_modify (block, offset_var, tmp);
+ if (src != dest)
+{
+ tree tmp = gfc_conv_descriptor_data_get (src);
+ gfc_conv_descriptor_data_set (block, dest, tmp);
+}
+
+ tree offset_var = gfc_create_var (gfc_array_index_type, "offset");
+ tree init_offset;
+ if (info.zero_based_src ())
+init_offset = gfc_index_zero_node;
+ else
+init_offset = gfc_conv_descriptor_offset_get (src);
+ gfc_add_modify (block, offset_var, init_offset);
/* Apply a shift of the lbound when supplied. */
for (int dim = 0; dim
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Annulation modif dump assumed_rank_12.f90
https://gcc.gnu.org/g:ac8ccbd19b684c86649d332a17e71a8d40ae6bbb
commit ac8ccbd19b684c86649d332a17e71a8d40ae6bbb
Author: Mikael Morin
Date: Wed Feb 5 11:45:00 2025 +0100
Annulation modif dump assumed_rank_12.f90
Diff:
---
gcc/fortran/trans-array.cc | 126 -
1 file changed, 124 insertions(+), 2 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 90eafe7ffe18..531281049646 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1085,11 +1085,131 @@ field_count (tree type)
}
-bool
+#if 0
+static bool
complete_init_p (tree type, vec *init_values)
{
return (unsigned) field_count (type) == vec_safe_length (init_values);
}
+#endif
+
+
+static int
+cmp_wi (const void *x, const void *y)
+{
+ const offset_int *wix = (const offset_int *) x;
+ const offset_int *wiy = (const offset_int *) y;
+
+ return wi::cmpu (*wix, *wiy);
+}
+
+
+static offset_int
+get_offset_bits (tree field)
+{
+ offset_int field_offset = wi::to_offset (DECL_FIELD_OFFSET (field));
+ offset_int field_bit_offset = wi::to_offset (DECL_FIELD_BIT_OFFSET (field));
+ unsigned long offset_align = DECL_OFFSET_ALIGN (field);
+
+ return field_offset * offset_align + field_bit_offset;
+}
+
+
+static bool
+check_cleared_low_bits (const offset_int &val, int bitcount)
+{
+ if (bitcount == 0)
+return true;
+
+ offset_int mask = wi::mask (bitcount, false);
+ if ((val & mask) != 0)
+return false;
+
+ return true;
+}
+
+
+static bool
+right_shift_if_clear (const offset_int &val, int bitcount, offset_int *result)
+{
+ if (bitcount == 0)
+{
+ *result = val;
+ return true;
+}
+
+ if (!check_cleared_low_bits (val, bitcount))
+return false;
+
+ *result = val >> bitcount;
+ return true;
+}
+
+
+static bool
+contiguous_init_p (tree type, tree value)
+{
+ gcc_assert (TREE_CODE (value) == CONSTRUCTOR);
+ auto_vec field_offsets;
+ int count = field_count (type);
+ field_offsets.reserve (count);
+
+ tree field = TYPE_FIELDS (type);
+ offset_int expected_offset = 0;
+ while (field != NULL_TREE)
+{
+ offset_int field_offset_bits = get_offset_bits (field);
+ offset_int field_offset;
+ if (!right_shift_if_clear (field_offset_bits, 3, &field_offset))
+ return false;
+
+ offset_int type_size = wi::to_offset (TYPE_SIZE_UNIT (TREE_TYPE
(field)));
+ int align = wi::ctz (type_size);
+ if (!check_cleared_low_bits (field_offset, align))
+ return false;
+
+ if (field_offset != expected_offset)
+ return false;
+
+ expected_offset += type_size;
+ field_offsets.quick_push (field_offset);
+
+ field = DECL_CHAIN (field);
+}
+
+ auto_vec value_offsets;
+ value_offsets.reserve (count);
+
+ unsigned i;
+ tree field_init;
+ FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (value), i, field, field_init)
+{
+ if (TREE_TYPE (field) != TREE_TYPE (field_init))
+ return false;
+
+ offset_int field_offset_bits = get_offset_bits (field);
+ offset_int field_offset;
+ if (!right_shift_if_clear (field_offset_bits, 3, &field_offset))
+ return false;
+
+ value_offsets.quick_push (field_offset);
+}
+
+ value_offsets.qsort (cmp_wi);
+
+ unsigned idx = 0;
+ offset_int field_off, val_off;
+ while (field_offsets.iterate (idx, &field_off)
+&& value_offsets.iterate (idx, &val_off))
+{
+ if (val_off != field_off)
+ return false;
+
+ idx++;
+}
+
+ return true;
+}
static bool
@@ -1161,7 +1281,9 @@ init_struct (stmtblock_t *block, tree data_ref, init_kind
kind,
if (TREE_STATIC (data_ref)
|| !modifiable_p (data_ref))
DECL_INITIAL (data_ref) = value;
- else if (TREE_CODE (value) == CONSTRUCTOR)
+ else if (TREE_CODE (value) == CONSTRUCTOR
+ && !(TREE_CONSTANT (value)
+ && contiguous_init_p (type, value)))
{
unsigned i;
tree field, field_init;
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation set_contiguous_array
https://gcc.gnu.org/g:b5834effc49cacae162a35ff2deafe3a9bbc9d1c commit b5834effc49cacae162a35ff2deafe3a9bbc9d1c Author: Mikael Morin Date: Fri Jan 17 17:48:42 2025 +0100 Factorisation set_contiguous_array Diff: --- gcc/fortran/trans-array.cc | 13 + 1 file changed, 1 insertion(+), 12 deletions(-) diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 76668d8a3ef1..88a2509a5246 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -11148,21 +11148,10 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, cdesc = gfc_create_var (cdesc, "cdesc"); DECL_ARTIFICIAL (cdesc) = 1; - gfc_add_modify (&dealloc_block, gfc_conv_descriptor_dtype (cdesc), - gfc_get_dtype_rank_type (1, tmp)); - gfc_conv_descriptor_lbound_set (&dealloc_block, cdesc, - gfc_index_zero_node, - gfc_index_one_node); - gfc_conv_descriptor_stride_set (&dealloc_block, cdesc, - gfc_index_zero_node, - gfc_index_one_node); - gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc, - gfc_index_zero_node, ubound); - if (attr->dimension) comp = gfc_conv_descriptor_data_get (comp); - gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp); + set_contiguous_array (&dealloc_block, cdesc, ubound, comp); /* Now call the deallocator. */ vtab = gfc_find_vtab (&c->ts);
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Correction régression alloc_comp_constructor_1.f90
https://gcc.gnu.org/g:deac09f715c2b3e0e91a6227871576632687809e
commit deac09f715c2b3e0e91a6227871576632687809e
Author: Mikael Morin
Date: Fri Feb 7 21:59:48 2025 +0100
Correction régression alloc_comp_constructor_1.f90
Diff:
---
gcc/fortran/trans-array.cc | 4 ++--
gcc/fortran/trans-expr.cc | 15 +--
2 files changed, 15 insertions(+), 4 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index b11bf5c1036e..d0f0e8465743 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1514,10 +1514,8 @@ static void
conv_shift_descriptor_lbound (stmtblock_t* block, tree from_desc, tree
to_desc, int dim,
tree new_lbound, tree offset, bool zero_based)
{
- /* Set lbound to the value we want. */
new_lbound = fold_convert (gfc_array_index_type, new_lbound);
new_lbound = gfc_evaluate_now (new_lbound, block);
- gfc_conv_descriptor_lbound_set (block, to_desc, gfc_rank_cst[dim],
new_lbound);
tree lbound = gfc_conv_descriptor_lbound_get (from_desc, gfc_rank_cst[dim]);
tree ubound = gfc_conv_descriptor_ubound_get (from_desc, gfc_rank_cst[dim]);
@@ -1539,6 +1537,8 @@ conv_shift_descriptor_lbound (stmtblock_t* block, tree
from_desc, tree to_desc,
tree tmp1 = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
ubound, diff);
gfc_conv_descriptor_ubound_set (block, to_desc, gfc_rank_cst[dim], tmp1);
+ /* Set lbound to the value we want. */
+ gfc_conv_descriptor_lbound_set (block, to_desc, gfc_rank_cst[dim],
new_lbound);
tree offs_diff = fold_build2_loc (input_location, MULT_EXPR,
gfc_array_index_type,
diff, stride);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 13a1ec1e8fe3..4f5c0782fda8 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -9335,11 +9335,22 @@ gfc_trans_alloc_subarray_assign (tree dest,
gfc_component * cm,
&& expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
arg = expr->value.function.actual->expr;
+ stmtblock_t shift_block;
+ gfc_init_block (&shift_block);
+ gfc_conv_shift_descriptor_subarray (&shift_block, dest, expr, arg);
+
+ tree data = gfc_conv_descriptor_data_get (se.expr);
+ data = fold_convert (pvoid_type_node, data);
+ tree non_null = fold_build2_loc (input_location, NE_EXPR, logical_type_node,
+ data, null_pointer_node);
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ non_null, gfc_finish_block (&shift_block),
+ build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&block, tmp);
+
if (expr->expr_type != EXPR_VARIABLE)
gfc_conv_descriptor_data_set (&block, se.expr, null_pointer_node);
- gfc_conv_shift_descriptor_subarray (&block, dest, expr, arg);
-
if (arg)
{
/* If a conversion expression has a null data pointer
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Déplacement méthode set_descriptor_from_scalar
https://gcc.gnu.org/g:da0f06041ed11f41d66b165320f27973c71d8186
commit da0f06041ed11f41d66b165320f27973c71d8186
Author: Mikael Morin
Date: Thu Jan 30 21:07:15 2025 +0100
Déplacement méthode set_descriptor_from_scalar
Correction erreur compil'
Diff:
---
gcc/fortran/trans-array.cc | 63 +++
gcc/fortran/trans-array.h | 3 ++
gcc/fortran/trans-expr.cc | 83 +-
3 files changed, 75 insertions(+), 74 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 4d08a862c5be..a1fb41fc9354 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1772,6 +1772,69 @@ gfc_set_descriptor_with_shape (stmtblock_t *block, tree
desc,
gfc_conv_descriptor_offset_set (block, desc, offset);
}
+/* Convert a scalar to an array descriptor. To be used for assumed-rank
+ arrays. */
+
+tree
+gfc_get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
+{
+ enum gfc_array_kind akind;
+
+ if (attr.pointer)
+akind = GFC_ARRAY_POINTER_CONT;
+ else if (attr.allocatable)
+akind = GFC_ARRAY_ALLOCATABLE;
+ else
+akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
+
+ if (POINTER_TYPE_P (TREE_TYPE (scalar)))
+scalar = TREE_TYPE (scalar);
+ return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
+ akind, !(attr.pointer || attr.target));
+}
+
+
+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);
+}
+
/* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 296a8052dd73..691231f66903 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -147,6 +147,9 @@ void gfc_clear_descriptor (stmtblock_t *block, gfc_symbol
*, gfc_expr *, tree);
void gfc_set_scalar_descriptor (stmtblock_t *block, tree, gfc_symbol *,
gfc_expr *, tree);
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);
/* Get a single array element. */
void gfc_conv_array_ref (gfc_se *, gfc_array_ref *, gfc_expr *, locus *);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 18d54d2a1f93..2ece9d369d80 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -83,34 +83,12 @@ gfc_get_character_len_in_bytes (tree type)
}
-/* Convert a scalar to an array descriptor. To be used for assumed-rank
- arrays. */
-
-static tree
-get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
-{
- enum gfc_array_kind akind;
-
- if (attr.pointer)
-akind = GFC_ARRAY_POINTER_CONT;
- else if (attr.allocatable)
-akind = GFC_ARRAY_ALLOCATABLE;
- else
-akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
-
- if (POINTER_TYPE_P (TREE_TYPE (scalar)))
-scalar = TREE_TYPE (scalar);
- return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
- akind, !(attr.pointer || attr.target));
-}
-
-
tree
gfc_conv_scalar_null_to_descriptor (gfc_se *se, gfc_symbol *sym, gfc_expr
*expr, tree scalar)
{
symbol_attribute attr = sym->attr;
- tree type = get_scalar_to_descriptor_type (scalar, attr);
+ tree type = gfc_get_scalar_to_descriptor_type (scalar, attr);
tree desc = gfc_create_var (type, "desc");
DECL_ARTIFICIAL (desc) = 1;
@@ -172,55 +150,12 @@ gfc_conv_null_array_descriptor (gfc_se *se, gfc_symbol
*sym, gfc_expr *expr)
}
-void
-set_descriptor_from_scalar (stmtblock_t *block, tree desc, tree scalar,
-
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation set_descriptor_dimension
https://gcc.gnu.org/g:30a92f59e09dc6c3b765b63a46e87e94ce628835
commit 30a92f59e09dc6c3b765b63a46e87e94ce628835
Author: Mikael Morin
Date: Fri Feb 7 12:07:36 2025 +0100
Factorisation set_descriptor_dimension
Correction compil'
Diff:
---
gcc/fortran/trans-array.cc | 82 +-
1 file changed, 44 insertions(+), 38 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index bf965dc68268..b11bf5c1036e 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1472,6 +1472,41 @@ gfc_build_null_descriptor (tree type)
}
+static tree
+set_descriptor_dimension (stmtblock_t *block, tree desc, int dim,
+ tree lbound, tree ubound, tree stride, tree *offset)
+{
+ /* Set bounds in descriptor. */
+ lbound = fold_convert (gfc_array_index_type, lbound);
+ lbound = gfc_evaluate_now (lbound, block);
+ gfc_conv_descriptor_lbound_set (block, desc,
+ gfc_rank_cst[dim], lbound);
+
+ ubound = fold_convert (gfc_array_index_type, ubound);
+ ubound = gfc_evaluate_now (ubound, block);
+ gfc_conv_descriptor_ubound_set (block, desc,
+ gfc_rank_cst[dim], ubound);
+
+ /* Set stride. */
+ stride = fold_convert (gfc_array_index_type, stride);
+ stride = gfc_evaluate_now (stride, block);
+ gfc_conv_descriptor_stride_set (block, desc,
+ gfc_rank_cst[dim], stride);
+
+ /* Update offset. */
+ tree tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, lbound, stride);
+ *offset = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, *offset, tmp);
+
+ /* Return stride for next dimension. */
+ tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ stride = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, stride, tmp);
+ return stride;
+}
+
+
/* Modify a descriptor such that the lbound of a given dimension is the value
specified. This also updates ubound and offset accordingly. */
@@ -1822,9 +1857,9 @@ gfc_conv_remap_descriptor (stmtblock_t *block, tree dest,
tree src,
/* Copy offset but adjust it such that it would correspond
to a lbound of zero. */
+ tree offset;
if (src_rank == -1)
-gfc_conv_descriptor_offset_set (block, dest,
- gfc_index_zero_node);
+offset = gfc_index_zero_node;
else
{
tree offs = gfc_conv_descriptor_offset_get (src);
@@ -1840,7 +1875,7 @@ gfc_conv_remap_descriptor (stmtblock_t *block, tree dest,
tree src,
offs = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, offs, tmp);
}
- gfc_conv_descriptor_offset_set (block, dest, offs);
+ offset = offs;
}
/* Set the bounds as declared for the LHS and calculate strides as
well as another offset update accordingly. */
@@ -1856,46 +1891,17 @@ gfc_conv_remap_descriptor (stmtblock_t *block, tree
dest, tree src,
/* Convert declared bounds. */
gfc_init_se (&lower_se, NULL);
gfc_init_se (&upper_se, NULL);
- gfc_conv_expr (&lower_se, as.lower[dim]);
- gfc_conv_expr (&upper_se, as.upper[dim]);
+ gfc_conv_expr_val (&lower_se, as.lower[dim]);
+ gfc_conv_expr_val (&upper_se, as.upper[dim]);
gfc_add_block_to_block (block, &lower_se.pre);
gfc_add_block_to_block (block, &upper_se.pre);
- tree lbound = fold_convert (gfc_array_index_type, lower_se.expr);
- tree ubound = fold_convert (gfc_array_index_type, upper_se.expr);
-
- lbound = gfc_evaluate_now (lbound, block);
- ubound = gfc_evaluate_now (ubound, block);
-
- gfc_add_block_to_block (block, &lower_se.post);
- gfc_add_block_to_block (block, &upper_se.post);
-
- /* Set bounds in descriptor. */
- gfc_conv_descriptor_lbound_set (block, dest,
- gfc_rank_cst[dim], lbound);
- gfc_conv_descriptor_ubound_set (block, dest,
- gfc_rank_cst[dim], ubound);
-
- /* Set stride. */
- stride = gfc_evaluate_now (stride, block);
- gfc_conv_descriptor_stride_set (block, dest,
- gfc_rank_cst[dim], stride);
-
- /* Update offset. */
- tree offs = gfc_conv_descriptor_offset_get (dest);
- tmp = fold_build2_loc (input_location, MULT_EXPR,
-gfc_array_index_type, lbound, stride);
- offs = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, offs, tmp);
- offs = gfc_evaluate_now (offs, block);
- gfc_conv_descriptor_offset_set (block, dest, offs);
-
- /* Update stride. */
- tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
- stride = fold_build2_loc (input_location, MULT_EX
[gcc r15-7434] aarch64: gimple fold aes[ed] [PR114522]
https://gcc.gnu.org/g:7d8e8f89732b1f13752e1b370852c7bcbbbde259
commit r15-7434-g7d8e8f89732b1f13752e1b370852c7bcbbbde259
Author: Andrew Pinski
Date: Tue Feb 4 22:24:52 2025 -0800
aarch64: gimple fold aes[ed] [PR114522]
Instead of waiting to get combine/rtl optimizations fixed here. This fixes
the
builtins at the gimple level. It should provide for slightly faster compile
time
since we have a simplification earlier on.
Built and tested for aarch64-linux-gnu.
gcc/ChangeLog:
PR target/114522
* config/aarch64/aarch64-builtins.cc (aarch64_fold_aes_op): New
function.
(aarch64_general_gimple_fold_builtin): Call aarch64_fold_aes_op for
crypto_aese
and crypto_aesd.
Signed-off-by: Andrew Pinski
Diff:
---
gcc/config/aarch64/aarch64-builtins.cc | 29 +
1 file changed, 29 insertions(+)
diff --git a/gcc/config/aarch64/aarch64-builtins.cc
b/gcc/config/aarch64/aarch64-builtins.cc
index 6d5479c2e449..128cc365d3d5 100644
--- a/gcc/config/aarch64/aarch64-builtins.cc
+++ b/gcc/config/aarch64/aarch64-builtins.cc
@@ -4722,6 +4722,30 @@ aarch64_fold_combine (gcall *stmt)
return gimple_build_assign (gimple_call_lhs (stmt), ctor);
}
+/* Fold a call to vaeseq_u8 and vaesdq_u8.
+ That is `vaeseq_u8 (x ^ y, 0)` gets folded
+ into `vaeseq_u8 (x, y)`.*/
+static gimple *
+aarch64_fold_aes_op (gcall *stmt)
+{
+ tree arg0 = gimple_call_arg (stmt, 0);
+ tree arg1 = gimple_call_arg (stmt, 1);
+ if (integer_zerop (arg0))
+arg0 = arg1;
+ else if (!integer_zerop (arg1))
+return nullptr;
+ if (TREE_CODE (arg0) != SSA_NAME)
+return nullptr;
+ if (!has_single_use (arg0))
+return nullptr;
+ auto *s = dyn_cast (SSA_NAME_DEF_STMT (arg0));
+ if (!s || gimple_assign_rhs_code (s) != BIT_XOR_EXPR)
+return nullptr;
+ gimple_call_set_arg (stmt, 0, gimple_assign_rhs1 (s));
+ gimple_call_set_arg (stmt, 1, gimple_assign_rhs2 (s));
+ return stmt;
+}
+
/* Fold a call to vld1, given that it loads something of type TYPE. */
static gimple *
aarch64_fold_load (gcall *stmt, tree type)
@@ -4983,6 +5007,11 @@ aarch64_general_gimple_fold_builtin (unsigned int fcode,
gcall *stmt,
gimple_call_set_lhs (new_stmt, gimple_call_lhs (stmt));
break;
+ VAR1 (BINOPU, crypto_aese, 0, DEFAULT, v16qi)
+ VAR1 (BINOPU, crypto_aesd, 0, DEFAULT, v16qi)
+ new_stmt = aarch64_fold_aes_op (stmt);
+ break;
+
/* Lower sqrt builtins to gimple/internal function sqrt. */
BUILTIN_VHSDF_DF (UNOP, sqrt, 2, FP)
new_stmt = gimple_build_call_internal (IFN_SQRT,
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation initialisation gfc depuis cfi
https://gcc.gnu.org/g:57a9d2504fe45acda17cd2b7efa99495c276f4df
commit 57a9d2504fe45acda17cd2b7efa99495c276f4df
Author: Mikael Morin
Date: Thu Jan 23 20:46:59 2025 +0100
Factorisation initialisation gfc depuis cfi
Correction régression scalar descriptor
Diff:
---
gcc/fortran/trans-expr.cc | 132 +-
1 file changed, 72 insertions(+), 60 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 6daa4a727f12..95b168fe76a8 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -5936,6 +5936,75 @@ set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
#endif
+static void
+set_gfc_from_cfi (stmtblock_t *block, tree gfc, tree cfi, tree rank,
+ gfc_symbol *c_sym)
+{
+ tree tmp = gfc_get_cfi_desc_base_addr (cfi);
+ gfc_conv_descriptor_data_set (block, gfc, tmp);
+
+ if (c_sym->attr.allocatable)
+{
+ /* gfc->span = cfi->elem_len. */
+ tmp = fold_convert (gfc_array_index_type,
+ gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
+}
+ else
+{
+ /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
+ ? cfi->dim[0].sm : cfi->elem_len). */
+ tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
+ tree tmp2 = fold_convert (gfc_array_index_type,
+ gfc_get_cfi_desc_elem_len (cfi));
+ tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
+gfc_array_index_type, tmp, tmp2);
+ tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+tmp, gfc_index_zero_node);
+ tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
+ gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]), tmp2);
+}
+ gfc_conv_descriptor_span_set (block, gfc, tmp);
+
+ /* Calculate offset + set lbound, ubound and stride. */
+ gfc_conv_descriptor_offset_set (block, gfc, gfc_index_zero_node);
+ /* Loop: for (i = 0; i < rank; ++i). */
+ tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
+ /* Loop body. */
+ stmtblock_t loop_body;
+ gfc_init_block (&loop_body);
+ /* gfc->dim[i].lbound = ... */
+ tmp = gfc_get_cfi_dim_lbound (cfi, idx);
+ gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp);
+
+ /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+gfc_conv_descriptor_lbound_get (gfc, idx),
+gfc_index_one_node);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+gfc_get_cfi_dim_extent (cfi, idx), tmp);
+ gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp);
+
+ /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
+ tmp = gfc_get_cfi_dim_sm (cfi, idx);
+ tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+gfc_array_index_type, tmp,
+fold_convert (gfc_array_index_type,
+ gfc_get_cfi_desc_elem_len (cfi)));
+ gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp);
+
+ /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
+ tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+gfc_conv_descriptor_stride_get (gfc, idx),
+gfc_conv_descriptor_lbound_get (gfc, idx));
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+gfc_conv_descriptor_offset_get (gfc), tmp);
+ gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp);
+ /* Generate loop. */
+ gfc_simple_for_loop (block, idx, build_int_cst (TREE_TYPE (idx), 0),
+ rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
+ gfc_finish_block (&loop_body));
+}
+
/* Provide an interface between gfortran array descriptors and the F2018:18.4
ISO_Fortran_binding array descriptors. */
@@ -6315,8 +6384,10 @@ done:
goto post_call;
gfc_init_block (&block2);
+
if (e->rank == 0)
{
+ gfc_init_block (&block2);
tmp = gfc_get_cfi_desc_base_addr (cfi);
gfc_add_modify (&block, gfc, fold_convert (TREE_TYPE (gfc), tmp));
}
@@ -6325,66 +6396,7 @@ done:
tmp = gfc_get_cfi_desc_base_addr (cfi);
gfc_conv_descriptor_data_set (&block, gfc, tmp);
- if (fsym->attr.allocatable)
- {
- /* gfc->span = cfi->elem_len. */
- tmp = fold_convert (gfc_array_index_type,
- gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
- }
- else
- {
- /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
- ? cfi->dim[0].sm : cfi->elem_len). */
- tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
- tmp2 = fold_convert (gfc_array_index_type,
- gfc_get_cfi_desc_elem_len (cfi
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Introduction gfc_conv_descriptor_extent_get
https://gcc.gnu.org/g:55a2a1029553f80b56f5a8c5ef8a5935c0dd1088
commit 55a2a1029553f80b56f5a8c5ef8a5935c0dd1088
Author: Mikael Morin
Date: Wed Jan 22 19:02:13 2025 +0100
Introduction gfc_conv_descriptor_extent_get
Diff:
---
gcc/fortran/trans-array.cc | 84 ++
gcc/fortran/trans-array.h | 1 +
gcc/fortran/trans-expr.cc | 6 +---
3 files changed, 50 insertions(+), 41 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 7afa29746e08..7357626be9a5 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -544,6 +544,51 @@ gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree
desc,
}
+/* Calculate the size of a given array dimension from the bounds. This
+ is simply (ubound - lbound + 1) if this expression is positive
+ or 0 if it is negative (pick either one if it is zero). Optionally
+ (if or_expr is present) OR the (expression != 0) condition to it. */
+
+static tree
+conv_array_extent_dim (tree lbound, tree ubound, bool maybe_negative, tree*
or_expr)
+{
+ tree res;
+ tree cond;
+
+ /* Calculate (ubound - lbound + 1). */
+ res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ubound, lbound);
+ res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
+gfc_index_one_node);
+
+ /* Check whether the size for this dimension is negative. */
+ if (maybe_negative)
+{
+ cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res,
+ gfc_index_zero_node);
+ res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
cond,
+gfc_index_zero_node, res);
+}
+
+ /* Build OR expression. */
+ if (maybe_negative && or_expr)
+*or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ logical_type_node, *or_expr, cond);
+
+ return res;
+}
+
+
+tree
+gfc_conv_descriptor_extent_get (tree desc, tree dim)
+{
+ tree ubound = gfc_conv_descriptor_ubound_get (desc, dim);
+ tree lbound = gfc_conv_descriptor_lbound_get (desc, dim);
+
+ return conv_array_extent_dim (lbound, ubound, false, NULL);
+}
+
+
static int
get_type_info (const bt &type)
{
@@ -7111,30 +7156,9 @@ gfc_set_delta (gfc_loopinfo *loop)
tree
gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
{
- tree res;
- tree cond;
-
- /* Calculate (ubound - lbound + 1). */
- res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
-ubound, lbound);
- res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
-gfc_index_one_node);
-
- /* Check whether the size for this dimension is negative. */
- cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res,
- gfc_index_zero_node);
- res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
-gfc_index_zero_node, res);
-
- /* Build OR expression. */
- if (or_expr)
-*or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
- logical_type_node, *or_expr, cond);
-
- return res;
+ return conv_array_extent_dim (lbound, ubound, true, or_expr);
}
-
/* For an array descriptor, get the total number of elements. This is just
the product of the extents along from_dim to to_dim. */
@@ -7148,14 +7172,7 @@ gfc_conv_descriptor_size_1 (tree desc, int from_dim, int
to_dim)
for (dim = from_dim; dim < to_dim; ++dim)
{
- tree lbound;
- tree ubound;
- tree extent;
-
- lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
- ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
-
- extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ tree extent = gfc_conv_descriptor_extent_get (desc, gfc_rank_cst[dim]);
res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
res, extent);
}
@@ -10543,12 +10560,7 @@ gfc_full_array_size (stmtblock_t *block, tree decl,
int rank)
tree nelems;
tree tmp;
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,
-nelems, tmp);
- tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
-tmp, gfc_index_one_node);
+ tmp = gfc_conv_descriptor_extent_get (decl, idx);
tmp = gfc_evaluate_now (tmp, block);
nelems = gfc_conv_descriptor_stride_get (decl, idx);
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index f9988a5fd109..1d694989b4c3 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -194,6 +194,7 @@ tree gfc_get_descriptor_
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Suppression code redondant
https://gcc.gnu.org/g:0aef3272bde76847317337411e9b7b75e74dc101
commit 0aef3272bde76847317337411e9b7b75e74dc101
Author: Mikael Morin
Date: Thu Jan 30 20:57:37 2025 +0100
Suppression code redondant
Diff:
---
gcc/fortran/trans-expr.cc | 8
1 file changed, 8 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 860224066167..18d54d2a1f93 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -193,14 +193,6 @@ set_descriptor_from_scalar (stmtblock_t *block, tree desc,
tree scalar,
gfc_conv_descriptor_span_set (block, desc, integer_zero_node);
- if (CONSTANT_CLASS_P (scalar))
-{
- tree tmp;
- tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
- gfc_add_modify (block, tmp, scalar);
- scalar = tmp;
-}
-
tree tmp;
if (is_class)
tmp = gfc_class_data_get (scalar);
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Sauvegarde factorisation set_descriptor_from_scalar
https://gcc.gnu.org/g:34baff548d9dc0913b69f129deb42a51686257db
commit 34baff548d9dc0913b69f129deb42a51686257db
Author: Mikael Morin
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 d6e7c9829ff2..90eafe7ffe18 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);
@@ -600,7 +601,7 @@ gfc_conv_descriptor_sm_get (tree desc, tree dim)
}
-static int
+static bt
get_type_info (const bt &type)
{
switch (type)
@@ -611,11 +612,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;
@@ -672,9 +675,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
@@ -698,8 +707,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
{
@@ -729,23 +744,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 ();
+ gf
[gcc r15-7430] arm: Prefer POP {lo-reg} over LDR lo-reg, ... for thumb2 [PR118089]
https://gcc.gnu.org/g:0b6453d5575d4aa773a1fe25060123bc6f539891
commit r15-7430-g0b6453d5575d4aa773a1fe25060123bc6f539891
Author: Richard Earnshaw
Date: Fri Feb 7 13:55:58 2025 +
arm: Prefer POP {lo-reg} over LDR lo-reg, ... for thumb2 [PR118089]
For thumb2, popping a single low register off the stack should prefer
POP over LDR to mirror the behaviour of the PUSH on entry. This saves
a couple of bytes in the resulting image. This is a relatively niche
case as it's rare to push a single low register onto the stack, but
still worth getting right.
Whilst fixing this I've also restructured the code here somewhat to
fix a bug I observed by inspection and to improve the code slightly.
Firstly, the single register case is hoisted above the main loop.
This not only avoids creating some RTL that immediately becomes
garbage but also avoids us needing to check for this case in every
iteration of the main loop body.
Secondly, we iterate over just the non-zero bits in the reg mask
rather than every bit and then checking if there's work to do for that
bit.
Finally, when emitting a pop that also pops SP off the stack we
shouldn't be emitting a stack-adjust CFA note. The new SP value comes
from the popped value, not from an adjustment of the previous SP
value.
gcc:
PR target/118089
* config/arm/arm.cc (arm_emit_multi_reg_pop): Restructure.
Don't emit LDR on thumb2 when POP can be used for smaller code.
Don't add a CFA adjust note when SP is popped off the stack.
gcc/testsuite:
PR target/118089
* gcc.target/arm/thumb2-pop-loreg.c: New test.
Diff:
---
gcc/config/arm/arm.cc | 99 ++---
gcc/testsuite/gcc.target/arm/thumb2-pop-loreg.c | 18 +
2 files changed, 75 insertions(+), 42 deletions(-)
diff --git a/gcc/config/arm/arm.cc b/gcc/config/arm/arm.cc
index 503401544cbe..a95ddf8201fa 100644
--- a/gcc/config/arm/arm.cc
+++ b/gcc/config/arm/arm.cc
@@ -22543,24 +22543,50 @@ static void
arm_emit_multi_reg_pop (unsigned long saved_regs_mask)
{
int num_regs = 0;
- int i, j;
rtx par;
rtx dwarf = NULL_RTX;
rtx tmp, reg;
bool return_in_pc = saved_regs_mask & (1 << PC_REGNUM);
int offset_adj;
int emit_update;
+ unsigned long reg_bits;
offset_adj = return_in_pc ? 1 : 0;
- for (i = 0; i <= LAST_ARM_REGNUM; i++)
-if (saved_regs_mask & (1 << i))
- num_regs++;
+ for (reg_bits = saved_regs_mask; reg_bits;
+ reg_bits &= ~(reg_bits & -reg_bits))
+num_regs++;
gcc_assert (num_regs && num_regs <= 16);
/* If SP is in reglist, then we don't emit SP update insn. */
emit_update = (saved_regs_mask & (1 << SP_REGNUM)) ? 0 : 1;
+ /* If popping just one register, use LDR reg, [SP], #4, unless
+ we're generating Thumb code and reg is a low reg. */
+ if (num_regs == 1
+ && emit_update
+ && !return_in_pc
+ && (TARGET_ARM
+ /* For Thumb we want to use POP for a single low register. */
+ || (saved_regs_mask & ~0xff)))
+{
+ int i = exact_log2 (saved_regs_mask);
+
+ rtx dwarf_reg = reg = gen_rtx_REG (SImode, i);
+ if (arm_current_function_pac_enabled_p () && i == IP_REGNUM)
+ dwarf_reg = gen_rtx_REG (SImode, RA_AUTH_CODE);
+ /* Emit single load with writeback. */
+ tmp = gen_frame_mem (SImode,
+ gen_rtx_POST_INC (Pmode,
+stack_pointer_rtx));
+ tmp = emit_insn (gen_rtx_SET (reg, tmp));
+ REG_NOTES (tmp) = alloc_reg_note (REG_CFA_RESTORE, dwarf_reg,
+ dwarf);
+ arm_add_cfa_adjust_cfa_note (tmp, UNITS_PER_WORD,
+ stack_pointer_rtx, stack_pointer_rtx);
+ return;
+}
+
/* The parallel needs to hold num_regs SETs
and one SET for the stack update. */
par = gen_rtx_PARALLEL (VOIDmode,
@@ -22582,50 +22608,39 @@ arm_emit_multi_reg_pop (unsigned long saved_regs_mask)
}
/* Now restore every reg, which may include PC. */
- for (j = 0, i = 0; j < num_regs; i++)
-if (saved_regs_mask & (1 << i))
- {
- rtx dwarf_reg = reg = gen_rtx_REG (SImode, i);
- if (arm_current_function_pac_enabled_p () && i == IP_REGNUM)
- dwarf_reg = gen_rtx_REG (SImode, RA_AUTH_CODE);
- if ((num_regs == 1) && emit_update && !return_in_pc)
- {
- /* Emit single load with writeback. */
- tmp = gen_frame_mem (SImode,
-gen_rtx_POST_INC (Pmode,
- stack_pointer_rtx));
- tmp = emit_insn (gen_rtx_SET (reg, tmp));
- REG_NOTES (tmp) = alloc_reg_note (REG_CFA_RESTORE, dwarf_reg,
- dwarf);
- arm_add_cfa_adjust_cfa_note (tmp,
[gcc r15-7429] arm: fix ICE due to fix for POP {PC} change
https://gcc.gnu.org/g:7bee37094c502de7c191ee5f2f9ce72789d27c99
commit r15-7429-g7bee37094c502de7c191ee5f2f9ce72789d27c99
Author: Richard Earnshaw
Date: Fri Feb 7 11:34:13 2025 +
arm: fix ICE due to fix for POP {PC} change
My earlier change for making the compiler prefer
POP {PC}
over
LDR PC, [SP], #4
had a slightly unexpected consequence in that we now also call
arm_emit_multi_reg_pop to handle single register pops when the
register is not PC. This exposed a latent bug in this function where
the dwarf unwinding notes on the single-register POP were not being
set correctly.
gcc/
PR target/118089
* config/arm/arm.cc (arm_emit_multi_reg_pop): Add a CFA adjust
note to single-register POP instructions.
Diff:
---
gcc/config/arm/arm.cc | 51 +++
1 file changed, 27 insertions(+), 24 deletions(-)
diff --git a/gcc/config/arm/arm.cc b/gcc/config/arm/arm.cc
index 7e2082101d83..503401544cbe 100644
--- a/gcc/config/arm/arm.cc
+++ b/gcc/config/arm/arm.cc
@@ -22563,7 +22563,8 @@ arm_emit_multi_reg_pop (unsigned long saved_regs_mask)
/* The parallel needs to hold num_regs SETs
and one SET for the stack update. */
- par = gen_rtx_PARALLEL (VOIDmode, rtvec_alloc (num_regs + emit_update +
offset_adj));
+ par = gen_rtx_PARALLEL (VOIDmode,
+ rtvec_alloc (num_regs + emit_update + offset_adj));
if (return_in_pc)
XVECEXP (par, 0, 0) = ret_rtx;
@@ -22571,11 +22572,11 @@ arm_emit_multi_reg_pop (unsigned long saved_regs_mask)
if (emit_update)
{
/* Increment the stack pointer, based on there being
- num_regs 4-byte registers to restore. */
+num_regs 4-byte registers to restore. */
tmp = gen_rtx_SET (stack_pointer_rtx,
- plus_constant (Pmode,
-stack_pointer_rtx,
-4 * num_regs));
+plus_constant (Pmode,
+ stack_pointer_rtx,
+ 4 * num_regs));
RTX_FRAME_RELATED_P (tmp) = 1;
XVECEXP (par, 0, offset_adj) = tmp;
}
@@ -22587,31 +22588,33 @@ arm_emit_multi_reg_pop (unsigned long saved_regs_mask)
rtx dwarf_reg = reg = gen_rtx_REG (SImode, i);
if (arm_current_function_pac_enabled_p () && i == IP_REGNUM)
dwarf_reg = gen_rtx_REG (SImode, RA_AUTH_CODE);
-if ((num_regs == 1) && emit_update && !return_in_pc)
- {
-/* Emit single load with writeback. */
-tmp = gen_frame_mem (SImode,
- gen_rtx_POST_INC (Pmode,
- stack_pointer_rtx));
-tmp = emit_insn (gen_rtx_SET (reg, tmp));
+ if ((num_regs == 1) && emit_update && !return_in_pc)
+ {
+ /* Emit single load with writeback. */
+ tmp = gen_frame_mem (SImode,
+gen_rtx_POST_INC (Pmode,
+ stack_pointer_rtx));
+ tmp = emit_insn (gen_rtx_SET (reg, tmp));
REG_NOTES (tmp) = alloc_reg_note (REG_CFA_RESTORE, dwarf_reg,
dwarf);
-return;
- }
+ arm_add_cfa_adjust_cfa_note (tmp, UNITS_PER_WORD,
+stack_pointer_rtx, stack_pointer_rtx);
+ return;
+ }
-tmp = gen_rtx_SET (reg,
- gen_frame_mem
- (SImode,
-plus_constant (Pmode, stack_pointer_rtx, 4 * j)));
-RTX_FRAME_RELATED_P (tmp) = 1;
-XVECEXP (par, 0, j + emit_update + offset_adj) = tmp;
+ tmp = gen_rtx_SET (reg,
+ gen_frame_mem
+ (SImode,
+ plus_constant (Pmode, stack_pointer_rtx, 4 * j)));
+ RTX_FRAME_RELATED_P (tmp) = 1;
+ XVECEXP (par, 0, j + emit_update + offset_adj) = tmp;
-/* We need to maintain a sequence for DWARF info too. As dwarf info
- should not have PC, skip PC. */
-if (i != PC_REGNUM)
+ /* We need to maintain a sequence for DWARF info too. As dwarf info
+ should not have PC, skip PC. */
+ if (i != PC_REGNUM)
dwarf = alloc_reg_note (REG_CFA_RESTORE, dwarf_reg, dwarf);
-j++;
+ j++;
}
if (return_in_pc)
[gcc r15-7431] Add a cache of recent lines
https://gcc.gnu.org/g:66af77cbed6c5bf15c19573ad21ebfd0552cc4b2
commit r15-7431-g66af77cbed6c5bf15c19573ad21ebfd0552cc4b2
Author: Andi Kleen
Date: Thu Dec 26 12:36:04 2024 -0800
Add a cache of recent lines
For larger files the file_cache line index will be spread out to make
the index fit into the fixed buffer, so any access to the non latest line
will need some skipping of lines.
Most accesses for line are near the latest line because
a diagnostic is likely near where the scanner is currently lexing.
Add a second cache for recent lines. It is organized as a ring buffer
and maintains the last 256 lines relative to the last input line.
With that, enabling -Wmisleading-indentation for the test case in
PR preprocessor/118168, is within the run-to-run variation.
gcc/ChangeLog:
PR preprocessor/118168
* input.cc (file_cache::m_line_recent,
m_line_recent_first, m_line_recent_last): Add.
(file_cache_slot::evict): Clear new fields.
(file_cache_slot::create): Clear new fields.
(file_cache_slot::file_cache_slot): Initialize new fields.
(file_cache_slot::~file_cache_slot): Release m_line_recent.
(file_cache_slot::get_next_line): Maintain ring buffer of lines
in m_line_recent.
(file_cache_slot::read_line_num): Use m_line_recent to look up
recent lines quickly.
Diff:
---
gcc/input.cc | 51 ++-
1 file changed, 50 insertions(+), 1 deletion(-)
diff --git a/gcc/input.cc b/gcc/input.cc
index 66a0ac6c5302..f0eacf59c8e2 100644
--- a/gcc/input.cc
+++ b/gcc/input.cc
@@ -126,6 +126,7 @@ public:
static const size_t buffer_size = 4 * 1024;
static size_t line_record_size;
+ static size_t recent_cached_lines_shift;
/* The number of time this file has been accessed. This is used
to designate which file cache to evict from the cache
@@ -177,6 +178,13 @@ public:
this is scaled down dynamically, with the line_info becoming anchors. */
vec m_line_record;
+ /* A cache of the recently seen lines. This is maintained as a ring
+ buffer. */
+ vec m_line_recent;
+
+ /* First and last valid entry in m_line_recent. */
+ size_t m_line_recent_last, m_line_recent_first;
+
void offset_buffer (int offset)
{
gcc_assert (offset < 0 ? m_alloc_offset + offset >= 0
@@ -190,6 +198,7 @@ public:
};
size_t file_cache_slot::line_record_size = 0;
+size_t file_cache_slot::recent_cached_lines_shift = 8;
/* Tune file_cache. */
void
@@ -395,6 +404,8 @@ file_cache_slot::evict ()
m_line_start_idx = 0;
m_line_num = 0;
m_line_record.truncate (0);
+ m_line_recent_first = 0;
+ m_line_recent_last = 0;
m_use_count = 0;
m_missing_trailing_newline = true;
}
@@ -491,6 +502,8 @@ file_cache_slot::create (const file_cache::input_context
&in_context,
m_nb_read = 0;
m_line_start_idx = 0;
m_line_num = 0;
+ m_line_recent_first = 0;
+ m_line_recent_last = 0;
m_line_record.truncate (0);
/* Ensure that this cache entry doesn't get evicted next time
add_file_to_cache_tab is called. */
@@ -597,9 +610,13 @@ file_cache::lookup_or_add_file (const char *file_path)
file_cache_slot::file_cache_slot ()
: m_use_count (0), m_file_path (NULL), m_fp (NULL), m_error (false), m_data
(0),
m_alloc_offset (0), m_size (0), m_nb_read (0), m_line_start_idx (0),
- m_line_num (0), m_missing_trailing_newline (true)
+ m_line_num (0), m_missing_trailing_newline (true),
+ m_line_recent_last (0), m_line_recent_first (0)
{
m_line_record.create (0);
+ m_line_recent.create (1U << recent_cached_lines_shift);
+ for (int i = 0; i < 1 << recent_cached_lines_shift; i++)
+m_line_recent.quick_push (file_cache_slot::line_info (0, 0, 0));
}
/* Destructor for a cache of file used by caret diagnostic. */
@@ -618,6 +635,7 @@ file_cache_slot::~file_cache_slot ()
m_data = 0;
}
m_line_record.release ();
+ m_line_recent.release ();
}
void
@@ -879,6 +897,20 @@ file_cache_slot::get_next_line (char **line, ssize_t
*line_len)
line_end - m_data));
}
+ /* Cache recent tail lines separately for fast access. This assumes
+ most accesses do not skip backwards. */
+ if (m_line_recent_last == m_line_recent_first
+ || m_line_recent[m_line_recent_last].line_num == m_line_num - 1)
+{
+ size_t mask = ((size_t)1 << recent_cached_lines_shift) - 1;
+ m_line_recent_last = (m_line_recent_last + 1) & mask;
+ if (m_line_recent_last == m_line_recent_first)
+ m_line_recent_first = (m_line_recent_first + 1) & mask;
+ m_line_recent[m_line_recent_last] =
+ file_cache_slot::line_info (m_line_num, m_line_start_idx,
+ line_end - m_data);
+}
+
/* Update m_line_start_idx so that it points to the next line to be
read. */
[gcc r15-7432] rs6000: Add cast to avoid pointer to integer comparison warning [PR117674]
https://gcc.gnu.org/g:c9b8a8fc55168ba9ec5432fc7b86621074e1b887 commit r15-7432-gc9b8a8fc55168ba9ec5432fc7b86621074e1b887 Author: Peter Bergner Date: Fri Feb 7 13:39:42 2025 -0600 rs6000: Add cast to avoid pointer to integer comparison warning [PR117674] 2025-02-07 Peter Bergner libgcc/ PR target/117674 * config/rs6000/linux-unwind.h (ppc_backchain_fallback): Add cast to avoid comparison between pointer and integer warning. Diff: --- libgcc/config/rs6000/linux-unwind.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libgcc/config/rs6000/linux-unwind.h b/libgcc/config/rs6000/linux-unwind.h index 97a9fbd2d1ae..6fd3c908ae84 100644 --- a/libgcc/config/rs6000/linux-unwind.h +++ b/libgcc/config/rs6000/linux-unwind.h @@ -395,7 +395,7 @@ ppc_backchain_fallback (struct _Unwind_Context *context, void *a) current = context->cfa; /* If the trace CFA is not the context CFA the backtrace is done. */ - if (arg == NULL || arg->cfa != current) + if (arg == NULL || arg->cfa != (_Unwind_Word) current) return; /* Start with next address. */
[gcc r15-7433] Fortran: fix initialization of allocatable non-deferred character [PR59252]
https://gcc.gnu.org/g:818c36a85e3faec5442eb26799bfa3bba7764b36
commit r15-7433-g818c36a85e3faec5442eb26799bfa3bba7764b36
Author: Harald Anlauf
Date: Fri Feb 7 21:21:10 2025 +0100
Fortran: fix initialization of allocatable non-deferred character [PR59252]
PR fortran/59252
gcc/fortran/ChangeLog:
* trans-expr.cc (gfc_trans_subcomponent_assign): Initialize
allocatable non-deferred character with NULL properly.
gcc/testsuite/ChangeLog:
* gfortran.dg/allocatable_char_1.f90: New test.
Diff:
---
gcc/fortran/trans-expr.cc| 8 +++-
gcc/testsuite/gfortran.dg/allocatable_char_1.f90 | 47
2 files changed, 53 insertions(+), 2 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index f923aeb94605..1329efcd6eb5 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -9836,9 +9836,13 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component
* cm,
tmp = gfc_trans_alloc_subarray_assign (tmp, cm, expr);
gfc_add_expr_to_block (&block, tmp);
}
- else if (init && cm->attr.allocatable && expr->expr_type == EXPR_NULL)
+ else if (cm->attr.allocatable && expr->expr_type == EXPR_NULL
+ && (init
+ || (cm->ts.type == BT_CHARACTER
+ && !(cm->ts.deferred || cm->attr.pdt_string
{
- /* NULL initialization for allocatable components. */
+ /* NULL initialization for allocatable components.
+Deferred-length character is dealt with later. */
gfc_add_modify (&block, dest, fold_convert (TREE_TYPE (dest),
null_pointer_node));
}
diff --git a/gcc/testsuite/gfortran.dg/allocatable_char_1.f90
b/gcc/testsuite/gfortran.dg/allocatable_char_1.f90
new file mode 100644
index ..1d6c25c4942d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/allocatable_char_1.f90
@@ -0,0 +1,47 @@
+! { dg-do run }
+! { dg-additional-options "-fdump-tree-original" }
+!
+! PR fortran/59252
+
+module mod
+ implicit none
+
+ type t1
+ character(256), allocatable :: label
+ end type t1
+
+ type t2
+ type(t1), allocatable :: appv(:)
+ end type t2
+
+contains
+ subroutine construct(res)
+type(t2), allocatable, intent(inout) :: res
+if (.not. allocated(res)) allocate(res)
+ end subroutine construct
+
+ subroutine construct_appv(appv)
+type(t1), allocatable, intent(inout) :: appv(:)
+if (.not. allocated(appv)) allocate(appv(20))
+ end subroutine construct_appv
+
+ type(t1) function foo () result (res)
+ end function foo
+end module mod
+
+program testy
+ use mod
+ implicit none
+ type(t2), allocatable :: res
+ type(t1) :: s
+
+ ! original test from pr59252
+ call construct (res)
+ call construct_appv(res%appv)
+ deallocate (res)
+
+ ! related test from pr118747 comment 2:
+ s = foo ()
+end program testy
+
+! { dg-final { scan-tree-dump-not "__builtin_memmove" "original" } }
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation set_descriptor_from_scalar dans gfc_conv_scalar_to_descriptor
https://gcc.gnu.org/g:01b40a54c893abe13bf134397e2f1651e4088d58
commit 01b40a54c893abe13bf134397e2f1651e4088d58
Author: Mikael Morin
Date: Wed Jan 29 19:05:04 2025 +0100
Factorisation set_descriptor_from_scalar dans gfc_conv_scalar_to_descriptor
Correction régression pr49213.f90
Correction régression associated_assumed_rank.f90
Diff:
---
gcc/fortran/trans-expr.cc | 67 +++
1 file changed, 38 insertions(+), 29 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 091e1417faed..860224066167 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -174,46 +174,61 @@ gfc_conv_null_array_descriptor (gfc_se *se, gfc_symbol
*sym, gfc_expr *expr)
void
set_descriptor_from_scalar (stmtblock_t *block, tree desc, tree scalar,
- gfc_expr *scalar_expr, bool is_class,
+ symbol_attribute scalar_attr, bool is_class,
tree cond_optional)
{
- tree type = get_scalar_to_descriptor_type (scalar,
-gfc_expr_attr (scalar_expr));
+ tree type = get_scalar_to_descriptor_type (scalar, scalar_attr);
if (POINTER_TYPE_P (type))
type = TREE_TYPE (type);
- tree dtype_val = gfc_get_dtype (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);
- tree tmp;
- if (is_class)
+ gfc_conv_descriptor_span_set (block, desc, integer_zero_node);
+
+ if (CONSTANT_CLASS_P (scalar))
{
- tmp = gfc_class_data_get (scalar);
- if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+ tree tmp;
+ tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
+ gfc_add_modify (block, tmp, scalar);
+ scalar = tmp;
}
- else if (cond_optional)
+
+ 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 (scalar),
- cond_optional, scalar,
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+ cond_optional, tmp,
fold_convert (TREE_TYPE (scalar),
null_pointer_node));
}
- else
-tmp = scalar;
gfc_conv_descriptor_data_set (block, desc, tmp);
}
+
tree
gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
{
- tree desc, type, etype;
+ tree desc, type;
type = get_scalar_to_descriptor_type (scalar, attr);
- etype = TREE_TYPE (scalar);
desc = gfc_create_var (type, "desc");
DECL_ARTIFICIAL (desc) = 1;
@@ -224,15 +239,9 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar,
symbol_attribute attr)
gfc_add_modify (&se->pre, tmp, scalar);
scalar = tmp;
}
- if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
-scalar = gfc_build_addr_expr (NULL_TREE, scalar);
- else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE)
-etype = TREE_TYPE (etype);
- gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
- gfc_get_dtype_rank_type (0, etype));
- gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
- gfc_conv_descriptor_span_set (&se->pre, desc,
- gfc_conv_descriptor_elem_len (desc));
+
+ set_descriptor_from_scalar (&se->pre, desc, scalar, attr,
+ false, NULL_TREE);
/* Copy pointer address back - but only if it could have changed and
if the actual argument is a pointer and not, e.g., NULL(). */
@@ -1082,8 +1091,8 @@ 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)
set_descriptor_from_scalar (&parmse->pre, ctree,
- parmse->expr, e, false,
- cond_optional);
+ parmse->expr, gfc_expr_attr (e),
+ false, cond_optional);
else
{
tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
@@ -1458,8 +1467,8 @@ 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)
- set_descriptor_from_scalar (&block, ctree, parmse->expr, e,
- true, NULL_TREE);
+ set_descriptor_from_scalar (&block, ctree, pa
[gcc r15-7436] x86: Verify that PUSH/POP can be skipped
https://gcc.gnu.org/g:846837c2406ae7a52d9123b29c13e4b8b9d14224
commit r15-7436-g846837c2406ae7a52d9123b29c13e4b8b9d14224
Author: H.J. Lu
Date: Fri Feb 7 13:49:30 2025 +0800
x86: Verify that PUSH/POP can be skipped
For
int f(int);
int advance(int dz)
{
if (dz > 0)
return (dz + dz) * dz;
else
return dz * f(dz);
}
Before r15-1619-g3b9b8d6cfdf593
advance(int):
pushrbx
mov ebx, edi
testedi, edi
jle .L2
imulebx, edi
lea eax, [rbx+rbx]
pop rbx
ret
.L2:
callf(int)
imuleax, ebx
pop rbx
ret
After
advance(int):
testedi, edi
jle .L2
imuledi, edi
lea eax, [rdi+rdi]
ret
.L2:
sub rsp, 24
mov DWORD PTR [rsp+12], edi
callf(int)
imuleax, DWORD PTR [rsp+12]
add rsp, 24
ret
There's no call in if branch, it's not optimal to push rbx at the entry
of the function, it can be sinked to else branch. When "jle .L2" is not
taken, it can save one push instruction. Update pr111673.c to verify
that this optimization isn't turned off.
PR rtl-optimization/111673
* gcc.target/i386/pr111673.c: Verify that PUSH/POP can be
skipped.
Signed-off-by: H.J. Lu
Diff:
---
gcc/testsuite/gcc.target/i386/pr111673.c | 14 ++
1 file changed, 14 insertions(+)
diff --git a/gcc/testsuite/gcc.target/i386/pr111673.c
b/gcc/testsuite/gcc.target/i386/pr111673.c
index 8d8a5a764f00..b9ceacf76512 100644
--- a/gcc/testsuite/gcc.target/i386/pr111673.c
+++ b/gcc/testsuite/gcc.target/i386/pr111673.c
@@ -1,5 +1,19 @@
/* { dg-do compile { target { ! ia32 } } } */
/* { dg-options "-O2 -fdump-rtl-pro_and_epilogue" } */
+/* Keep labels and directives ('.cfi_startproc', '.cfi_endproc'). */
+/* { dg-final { check-function-bodies "**" "" "" { target "*-*-*" } {^\t?\.}
} } */
+
+/*
+**advance:
+**.LFB0:
+** .cfi_startproc
+** testl %edi, %edi
+** jle .L2
+** imull %edi, %edi
+** leal\(%rdi,%rdi\), %eax
+** ret
+**...
+*/
/* Verify there is an early return without the prolog and shrink-wrap
the function. */
[gcc r15-7405] [gcn] Fix gfx906's sramecc setting
https://gcc.gnu.org/g:fa5544625d585a29463acce1f32a7f6fa13e3431
commit r15-7405-gfa5544625d585a29463acce1f32a7f6fa13e3431
Author: Tobias Burnus
Date: Fri Feb 7 10:44:18 2025 +0100
[gcn] Fix gfx906's sramecc setting
When compiling with -g, mkoffload.cc creates a device object file itself;
however, in order that the linker dos not complain, the ELF flags must
match what the compiler / linker does. For gfx906, the assembler defaults
to sramecc = any, but gcn-devices.def contained unsupported, which is not
the same - causing link errors. That's a regression caused by commit
r15-4540-ga6b26e5ea09779 - which can be best seen by looking at the
changes to mkoffload.cc.
Additionally, this commit adds '...' to the GCN_DEVICE #define in gcn.cc
to make it agnostic to the addition of fields.
gcc/ChangeLog:
* config/gcn/gcn-devices.def (GCN_DEVICE): Change sramecc for
gfx906 to 'any'.
* config/gcn/gcn.cc (GCN_DEVICE): Add tailing ... to #define.
Diff:
---
gcc/config/gcn/gcn-devices.def | 2 +-
gcc/config/gcn/gcn.cc | 3 ++-
2 files changed, 3 insertions(+), 2 deletions(-)
diff --git a/gcc/config/gcn/gcn-devices.def b/gcc/config/gcn/gcn-devices.def
index 7d47a7b495d4..a8b21a358b48 100644
--- a/gcc/config/gcn/gcn-devices.def
+++ b/gcc/config/gcn/gcn-devices.def
@@ -91,7 +91,7 @@ GCN_DEVICE(gfx900, GFX900, 0x2c, ISA_GCN5,
GCN_DEVICE(gfx906, GFX906, 0x2f, ISA_GCN5,
/* XNACK default */ HSACO_ATTR_OFF,
- /* SRAM_ECC default */ HSACO_ATTR_UNSUPPORTED,
+ /* SRAM_ECC default */ HSACO_ATTR_ANY,
/* WAVE64 mode */ HSACO_ATTR_UNSUPPORTED,
/* CU mode */ HSACO_ATTR_UNSUPPORTED,
/* Max ISA VGPRs */ 256,
diff --git a/gcc/config/gcn/gcn.cc b/gcc/config/gcn/gcn.cc
index 4200cfaf0063..82fc6ff1e413 100644
--- a/gcc/config/gcn/gcn.cc
+++ b/gcc/config/gcn/gcn.cc
@@ -101,7 +101,8 @@ static hash_map lds_allocs;
/* Import all the data from gcn-devices.def.
The PROCESSOR_GFXnnn should be indices for this table. */
const struct gcn_device_def gcn_devices[] = {
-#define GCN_DEVICE(name, NAME, ELF, ISA, XNACK, SRAMECC, WAVE64, CU, VGPRS,
GEN_VER,ARCH_FAM) \
+#define GCN_DEVICE(name, NAME, ELF, ISA, XNACK, SRAMECC, WAVE64, CU, VGPRS, \
+ GEN_VER, ARCH_FAM, ...) \
{PROCESSOR_ ## NAME, #name, #NAME, ISA, XNACK, SRAMECC, WAVE64, CU, VGPRS,
\
GEN_VER, #ARCH_FAM},
#include "gcn-devices.def"
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation set_descriptor_dimension
https://gcc.gnu.org/g:e4b734b096732b9a2264ea1a9869e0b73f7ce654
commit e4b734b096732b9a2264ea1a9869e0b73f7ce654
Author: Mikael Morin
Date: Fri Feb 7 12:07:36 2025 +0100
Factorisation set_descriptor_dimension
Diff:
---
gcc/fortran/trans-array.cc | 82 +-
1 file changed, 44 insertions(+), 38 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index d5c7b1344697..298fbc8d8bfd 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1472,6 +1472,41 @@ gfc_build_null_descriptor (tree type)
}
+static tree
+set_descriptor_dimension (stmtblock_t *block, tree desc, int dim,
+ tree lbound, tree ubound, tree stride, tree *offset)
+{
+ /* Set bounds in descriptor. */
+ lbound = fold_convert (gfc_array_index_type, lbound);
+ lbound = gfc_evaluate_now (lbound, block);
+ gfc_conv_descriptor_lbound_set (block, desc,
+ gfc_rank_cst[dim], lbound);
+
+ ubound = fold_convert (gfc_array_index_type, upper);
+ ubound = gfc_evaluate_now (ubound, block);
+ gfc_conv_descriptor_ubound_set (block, desc,
+ gfc_rank_cst[dim], ubound);
+
+ /* Set stride. */
+ stride = fold_convert (gfc_array_index_type, stride);
+ stride = gfc_evaluate_now (stride, block);
+ gfc_conv_descriptor_stride_set (block, desc,
+ gfc_rank_cst[dim], stride);
+
+ /* Update offset. */
+ tree tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, lbound, stride);
+ *offset = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, *offset, tmp);
+
+ /* Update stride. */
+ tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ stride = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, stride, tmp);
+ return stride;
+}
+
+
/* Modify a descriptor such that the lbound of a given dimension is the value
specified. This also updates ubound and offset accordingly. */
@@ -1821,9 +1856,9 @@ gfc_conv_remap_descriptor (stmtblock_t *block, tree dest,
tree src,
/* Copy offset but adjust it such that it would correspond
to a lbound of zero. */
+ tree offset;
if (src_rank == -1)
-gfc_conv_descriptor_offset_set (block, dest,
- gfc_index_zero_node);
+offset = gfc_index_zero_node;
else
{
tree offs = gfc_conv_descriptor_offset_get (src);
@@ -1839,7 +1874,7 @@ gfc_conv_remap_descriptor (stmtblock_t *block, tree dest,
tree src,
offs = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, offs, tmp);
}
- gfc_conv_descriptor_offset_set (block, dest, offs);
+ offset = offs;
}
/* Set the bounds as declared for the LHS and calculate strides as
well as another offset update accordingly. */
@@ -1855,46 +1890,17 @@ gfc_conv_remap_descriptor (stmtblock_t *block, tree
dest, tree src,
/* Convert declared bounds. */
gfc_init_se (&lower_se, NULL);
gfc_init_se (&upper_se, NULL);
- gfc_conv_expr (&lower_se, as.lower[dim]);
- gfc_conv_expr (&upper_se, as.upper[dim]);
+ gfc_conv_expr_val (&lower_se, as.lower[dim]);
+ gfc_conv_expr_val (&upper_se, as.upper[dim]);
gfc_add_block_to_block (block, &lower_se.pre);
gfc_add_block_to_block (block, &upper_se.pre);
- tree lbound = fold_convert (gfc_array_index_type, lower_se.expr);
- tree ubound = fold_convert (gfc_array_index_type, upper_se.expr);
-
- lbound = gfc_evaluate_now (lbound, block);
- ubound = gfc_evaluate_now (ubound, block);
-
- gfc_add_block_to_block (block, &lower_se.post);
- gfc_add_block_to_block (block, &upper_se.post);
-
- /* Set bounds in descriptor. */
- gfc_conv_descriptor_lbound_set (block, dest,
- gfc_rank_cst[dim], lbound);
- gfc_conv_descriptor_ubound_set (block, dest,
- gfc_rank_cst[dim], ubound);
-
- /* Set stride. */
- stride = gfc_evaluate_now (stride, block);
- gfc_conv_descriptor_stride_set (block, dest,
- gfc_rank_cst[dim], stride);
-
- /* Update offset. */
- tree offs = gfc_conv_descriptor_offset_get (dest);
- tmp = fold_build2_loc (input_location, MULT_EXPR,
-gfc_array_index_type, lbound, stride);
- offs = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, offs, tmp);
- offs = gfc_evaluate_now (offs, block);
- gfc_conv_descriptor_offset_set (block, dest, offs);
-
- /* Update stride. */
- tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
- stride = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_in
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Correction compil'
https://gcc.gnu.org/g:e8d82306d889e31bfefe89be0936403bb28403b3 commit e8d82306d889e31bfefe89be0936403bb28403b3 Author: Mikael Morin Date: Fri Feb 7 12:09:45 2025 +0100 Correction compil' Diff: --- gcc/fortran/trans-array.cc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 298fbc8d8bfd..46db59383d1c 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -1482,7 +1482,7 @@ set_descriptor_dimension (stmtblock_t *block, tree desc, int dim, gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], lbound); - ubound = fold_convert (gfc_array_index_type, upper); + ubound = fold_convert (gfc_array_index_type, ubound); ubound = gfc_evaluate_now (ubound, block); gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound); @@ -1499,7 +1499,7 @@ set_descriptor_dimension (stmtblock_t *block, tree desc, int dim, *offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, *offset, tmp); - /* Update stride. */ + /* Return stride for next dimension. */ tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL); stride = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, stride, tmp);
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Utilisation gfc_clear_descriptor dans gfc_conv_derived_to_class
https://gcc.gnu.org/g:db8dddefb7b3659f1307058b98421fc9edf2e6de
commit db8dddefb7b3659f1307058b98421fc9edf2e6de
Author: Mikael Morin
Date: Wed Dec 11 16:03:10 2024 +0100
Utilisation gfc_clear_descriptor dans gfc_conv_derived_to_class
essai suppression
Suppression fonction inutilisée
Sauvegarde compilation OK
Correction régression
Sauvegarde correction null_actual_6
Commentage fonction inutilisée
Correction bornes descripteur null
Diff:
---
gcc/fortran/trans-array.cc | 339 +++--
gcc/fortran/trans-array.h | 4 +-
gcc/fortran/trans-expr.cc | 87 ++--
3 files changed, 373 insertions(+), 57 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index d15576adde10..0370d10d9ebd 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -592,10 +592,10 @@ get_size_info (gfc_typespec &ts)
if (POINTER_TYPE_P (type))
type = TREE_TYPE (type);
gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
- tree elt_type = TREE_TYPE (type);
+ tree char_type = TREE_TYPE (type);
tree len = ts.u.cl->backend_decl;
return fold_build2_loc (input_location, MULT_EXPR, size_type_node,
- size_in_bytes (elt_type),
+ size_in_bytes (char_type),
fold_convert (size_type_node, len));
}
@@ -613,8 +613,61 @@ get_size_info (gfc_typespec &ts)
}
+class init_info
+{
+public:
+ virtual bool initialize_data () const { return false; }
+ virtual tree get_data_value () const { return NULL_TREE; }
+ virtual gfc_typespec *get_type () const { return nullptr; }
+};
+
+
+class default_init : public init_info
+{
+private:
+ const symbol_attribute &attr;
+
+public:
+ default_init (const symbol_attribute &arg_attr) : attr(arg_attr) { }
+ virtual bool initialize_data () const { return !attr.pointer; }
+ virtual tree get_data_value () const {
+if (!initialize_data ())
+ return NULL_TREE;
+
+return null_pointer_node;
+ }
+};
+
+class nullification : public init_info
+{
+private:
+ gfc_typespec &ts;
+
+public:
+ nullification(gfc_typespec &arg_ts) : ts(arg_ts) { }
+ virtual bool initialize_data () const { return true; }
+ virtual tree get_data_value () const { return null_pointer_node; }
+ virtual gfc_typespec *get_type () const { return &ts; }
+};
+
+class scalar_value : public init_info
+{
+private:
+ gfc_typespec &ts;
+ tree value;
+
+public:
+ scalar_value(gfc_typespec &arg_ts, tree arg_value)
+: ts(arg_ts), value(arg_value) { }
+ virtual bool initialize_data () const { return true; }
+ virtual tree get_data_value () const { return value; }
+ virtual gfc_typespec *get_type () const { return &ts; }
+};
+
+
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 *v = nullptr;
@@ -622,11 +675,17 @@ build_dtype (gfc_typespec &ts, int rank, const
symbol_attribute &)
tree fields = TYPE_FIELDS (type);
- if (ts.type != BT_CLASS)
+ gfc_typespec *type_info = init.get_type ();
+ if (type_info == nullptr)
+type_info = &ts;
+
+ if (!(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 (ts));
+ get_size_info (*type_info));
CONSTRUCTOR_APPEND_ELT (v, elem_len_field, elem_len_val);
}
@@ -641,11 +700,11 @@ build_dtype (gfc_typespec &ts, int rank, const
symbol_attribute &)
CONSTRUCTOR_APPEND_ELT (v, rank_field, rank_val);
}
- if (ts.type != BT_CLASS)
+ if (type_info->type != BT_CLASS)
{
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 (ts));
+ get_type_info (*type_info));
CONSTRUCTOR_APPEND_ELT (v, type_info_field, type_info_val);
}
@@ -656,8 +715,8 @@ build_dtype (gfc_typespec &ts, int rank, const
symbol_attribute &)
/* Build a null array descriptor constructor. */
vec *
-get_default_descriptor_init (tree type, gfc_typespec &ts, int rank,
-const symbol_attribute &attr)
+get_descriptor_init (tree type, gfc_typespec &ts, int rank,
+const symbol_attribute &attr, const init_info &init)
{
vec *v = nullptr;
@@ -666,15 +725,15 @@ get_default_descriptor_init (tree type, gfc_typespec &ts,
int rank,
tree fields = TYPE_FIELDS (type);
/* Don't init pointers by default. */
- if
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Appel méthode shift descriptor dans gfc_trans_pointer_assignment
https://gcc.gnu.org/g:ecdc8da68c9d5419d4c0e6ec9b1b3278076cbdf0
commit ecdc8da68c9d5419d4c0e6ec9b1b3278076cbdf0
Author: Mikael Morin
Date: Tue Dec 17 22:37:18 2024 +0100
Appel méthode shift descriptor dans gfc_trans_pointer_assignment
Diff:
---
gcc/fortran/trans-array.cc | 129 +++--
gcc/fortran/trans-array.h | 1 +
gcc/fortran/trans-expr.cc | 28 +-
3 files changed, 129 insertions(+), 29 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 2fdd15962e49..cdbff27d82ca 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1151,13 +1151,136 @@ gfc_conv_shift_descriptor_lbound (stmtblock_t* block,
tree desc,
}
+class lb_info
+{
+public:
+ virtual gfc_expr *lower_bound (int dim) const = 0;
+};
+
+
+class unset_lb : public lb_info
+{
+public:
+ virtual gfc_expr *lower_bound (int) const { return nullptr; }
+};
+
+
+class defined_lb : public lb_info
+{
+ int rank;
+ gfc_expr * const * lower_bounds;
+
+public:
+ defined_lb (int arg_rank, gfc_expr * const
arg_lower_bounds[GFC_MAX_DIMENSIONS])
+: rank(arg_rank), lower_bounds(arg_lower_bounds) { }
+ virtual gfc_expr *lower_bound (int dim) const { return lower_bounds[dim]; }
+};
+
+
static void
-conv_shift_descriptor (stmtblock_t* block, tree desc, int rank)
+conv_shift_descriptor (stmtblock_t *block, tree desc, int rank,
+ const lb_info &info)
{
/* Apply a shift of the lbound when supplied. */
for (int dim = 0; dim < rank; ++dim)
-gfc_conv_shift_descriptor_lbound (block, desc, dim,
- gfc_index_one_node);
+{
+ gfc_expr *lb_expr = info.lower_bound(dim);
+
+ tree lower_bound;
+ if (lb_expr == nullptr)
+ lower_bound = gfc_index_one_node;
+ else
+ {
+ gfc_se lb_se;
+
+ gfc_init_se (&lb_se, nullptr);
+ gfc_conv_expr (&lb_se, lb_expr);
+
+ gfc_add_block_to_block (block, &lb_se.pre);
+ tree lb_var = gfc_create_var (TREE_TYPE (lb_se.expr), "lower_bound");
+ gfc_add_modify (block, lb_var, lb_se.expr);
+ gfc_add_block_to_block (block, &lb_se.post);
+
+ lower_bound = lb_var;
+ }
+
+ gfc_conv_shift_descriptor_lbound (block, desc, dim, lower_bound);
+}
+}
+
+
+static void
+conv_shift_descriptor (stmtblock_t* block, tree desc, int rank)
+{
+ conv_shift_descriptor (block, desc, rank, unset_lb ());
+}
+
+
+static void
+conv_shift_descriptor (stmtblock_t *block, tree desc, int rank,
+ gfc_expr * const lower_bounds[GFC_MAX_DIMENSIONS])
+{
+ conv_shift_descriptor (block, desc, rank, defined_lb (rank, lower_bounds));
+}
+
+
+static void
+conv_shift_descriptor (stmtblock_t *block, tree desc,
+ const gfc_array_spec &as)
+{
+ conv_shift_descriptor (block, desc, as.rank, as.lower);
+}
+
+
+static void
+set_type (array_type &type, array_type value)
+{
+ gcc_assert (type == AS_UNKNOWN || type == value);
+ type = value;
+}
+
+
+static void
+array_ref_to_array_spec (const gfc_array_ref &ref, gfc_array_spec &spec)
+{
+ spec.rank = ref.dimen;
+ spec.corank = ref.codimen;
+
+ spec.type = AS_UNKNOWN;
+ spec.cotype = AS_ASSUMED_SIZE;
+
+ for (int dim = 0; dim < spec.rank + spec.corank; dim++)
+switch (ref.dimen_type[dim])
+ {
+ case DIMEN_ELEMENT:
+ spec.upper[dim] = ref.start[dim];
+ set_type (spec.type, AS_EXPLICIT);
+ break;
+
+ case DIMEN_RANGE:
+ spec.lower[dim] = ref.start[dim];
+ spec.upper[dim] = ref.end[dim];
+ if (spec.upper[dim] == nullptr)
+ set_type (spec.type, AS_DEFERRED);
+ else
+ set_type (spec.type, AS_EXPLICIT);
+ break;
+
+ default:
+ break;
+ }
+}
+
+
+void
+gfc_conv_shift_descriptor (stmtblock_t *block, tree desc,
+ const gfc_array_ref &ar)
+{
+ gfc_array_spec as;
+
+ array_ref_to_array_spec (ar, as);
+
+ conv_shift_descriptor (block, desc, as);
}
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 17e3d08fdba0..3b05a2eb197a 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -214,6 +214,7 @@ tree gfc_get_cfi_dim_sm (tree, tree);
/* Shift lower bound of descriptor, updating ubound and offset. */
void gfc_conv_shift_descriptor_lbound (stmtblock_t*, tree, int, tree);
+void gfc_conv_shift_descriptor (stmtblock_t*, tree, const gfc_array_ref &);
/* Add pre-loop scalarization code for intrinsic functions which require
special handling. */
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index e8b229d853e3..1de4a73974d6 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -11180,32 +11180,8 @@ gfc_trans_pointer_assignment (gfc_expr * expr1,
gfc_expr * expr2)
}
}
else
- {
- /* Bounds remapping. Just shift the lower bounds. */
-
-
[gcc] Created branch 'mikael/heads/refactor_descriptor_v01' in namespace 'refs/users'
The branch 'mikael/heads/refactor_descriptor_v01' was created in namespace 'refs/users' pointing to: 4ffb2a232685... Factorisation set_descriptor_dimension
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation initialisation depuis cfi
https://gcc.gnu.org/g:1392f13442685eacd23ee09a10daccbaf00481ec
commit 1392f13442685eacd23ee09a10daccbaf00481ec
Author: Mikael Morin
Date: Fri Jan 24 16:01:58 2025 +0100
Factorisation initialisation depuis cfi
Correction régression contiguous-2.f90
Correction regression contiguous-2.f90
Correction régression bind-c-contiguous-1.f90
Diff:
---
gcc/fortran/trans-decl.cc | 220 --
gcc/fortran/trans-expr.cc | 209 ---
gcc/fortran/trans.h | 2 +
3 files changed, 194 insertions(+), 237 deletions(-)
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index dad15858fa6a..baa36e88bf15 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -7009,7 +7009,7 @@ gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t
*finally,
stmtblock_t block;
gfc_init_block (&block);
tree cfi = build_fold_indirect_ref_loc (input_location, cfi_desc);
- tree idx, etype, tmp, tmp2, size_var = NULL_TREE, rank = NULL_TREE;
+ tree idx, tmp, tmp2, size_var = NULL_TREE, rank = NULL_TREE;
bool do_copy_inout = false;
/* When allocatable + intent out, free the cfi descriptor. */
@@ -7201,106 +7201,10 @@ gfc_conv_cfi_to_gfc (stmtblock_t *init, stmtblock_t
*finally,
goto done;
}
- if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_desc)))
-{
- /* gfc->dtype = ... (from declaration, not from cfi). */
- etype = gfc_get_element_type (TREE_TYPE (gfc_desc));
- gfc_add_modify (&block, gfc_conv_descriptor_dtype (gfc_desc),
- gfc_get_dtype_rank_type (sym->as->rank, etype));
- /* gfc->data = cfi->base_addr. */
- gfc_conv_descriptor_data_set (&block, gfc_desc,
- gfc_get_cfi_desc_base_addr (cfi));
-}
-
- if (sym->ts.type == BT_ASSUMED)
-{
- /* For type(*), take elem_len + dtype.type from the actual argument. */
- gfc_add_modify (&block, gfc_conv_descriptor_elem_len (gfc_desc),
- gfc_get_cfi_desc_elem_len (cfi));
- tree cond;
- tree ctype = gfc_get_cfi_desc_type (cfi);
- ctype = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (ctype),
- ctype, build_int_cst (TREE_TYPE (ctype),
-CFI_type_mask));
- tree type = gfc_conv_descriptor_type (gfc_desc);
-
- /* if (CFI_type_cptr) BT_VOID else BT_UNKNOWN */
- /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
ctype,
- build_int_cst (TREE_TYPE (ctype), CFI_type_cptr));
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
-build_int_cst (TREE_TYPE (type), BT_VOID));
- tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
- type,
- build_int_cst (TREE_TYPE (type), BT_UNKNOWN));
- tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
- /* if (CFI_type_struct) BT_DERIVED else < tmp2 > */
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
ctype,
- build_int_cst (TREE_TYPE (ctype),
-CFI_type_struct));
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
-build_int_cst (TREE_TYPE (type), BT_DERIVED));
- tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
- /* if (CFI_type_Character) BT_CHARACTER else < tmp2 > */
- /* Note: this is kind=1, CFI_type_ucs4_char is handled in the 'else if'
-before (see below, as generated bottom up). */
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
ctype,
- build_int_cst (TREE_TYPE (ctype),
- CFI_type_Character));
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
-build_int_cst (TREE_TYPE (type), BT_CHARACTER));
- tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
- /* if (CFI_type_ucs4_char) BT_CHARACTER else < tmp2 > */
- /* Note: gfc->elem_len = cfi->elem_len/4. */
- /* However, assuming that CFI_type_ucs4_char cannot be recovered, leave
-gfc->elem_len == cfi->elem_len, which helps with operations which use
-sizeof() in Fortran and cfi->elem_len in C. */
- tmp = gfc_get_cfi_desc_type (cfi);
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, tmp,
- build_int_cst (TREE_TYPE (tmp),
-
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation set_descriptor_from_scalar dans conv_class_to_class
https://gcc.gnu.org/g:60fb6b7d916d2d309ca305c8848baefe06ae06c6
commit 60fb6b7d916d2d309ca305c8848baefe06ae06c6
Author: Mikael Morin
Date: Tue Jan 28 21:03:24 2025 +0100
Factorisation set_descriptor_from_scalar dans conv_class_to_class
Correction régression associate_66
Correction régression PR100040.f90
Diff:
---
gcc/fortran/trans-expr.cc | 34 ++
1 file changed, 22 insertions(+), 12 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index a5cd0a452d81..6afb344245f2 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -172,6 +172,27 @@ gfc_conv_null_array_descriptor (gfc_se *se, gfc_symbol
*sym, gfc_expr *expr)
}
+void
+set_descriptor_from_scalar (stmtblock_t *block, tree desc, tree scalar,
+ gfc_expr *scalar_expr)
+{
+ tree type = get_scalar_to_descriptor_type (scalar,
+gfc_expr_attr (scalar_expr));
+ if (POINTER_TYPE_P (type))
+type = TREE_TYPE (type);
+
+ tree dtype_val = gfc_get_dtype (type);
+ tree dtype_ref = gfc_conv_descriptor_dtype (desc);
+ gfc_add_modify (block, dtype_ref, dtype_val);
+
+ tree tmp = gfc_class_data_get (scalar);
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+
+ gfc_conv_descriptor_data_set (block, desc, tmp);
+}
+
+
tree
gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
{
@@ -1434,18 +1455,7 @@ 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)
- {
- tree type = get_scalar_to_descriptor_type (parmse->expr,
-gfc_expr_attr (e));
- gfc_add_modify (&block, gfc_conv_descriptor_dtype (ctree),
- gfc_get_dtype (type));
-
- tmp = gfc_class_data_get (parmse->expr);
- if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
-
- gfc_conv_descriptor_data_set (&block, ctree, tmp);
- }
+ set_descriptor_from_scalar (&block, ctree, parmse->expr, e);
else
gfc_class_array_data_assign (&block, ctree, parmse->expr, false);
}
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation initialisation gfc depuis cfi
https://gcc.gnu.org/g:57a9d2504fe45acda17cd2b7efa99495c276f4df
commit 57a9d2504fe45acda17cd2b7efa99495c276f4df
Author: Mikael Morin
Date: Thu Jan 23 20:46:59 2025 +0100
Factorisation initialisation gfc depuis cfi
Correction régression scalar descriptor
Diff:
---
gcc/fortran/trans-expr.cc | 132 +-
1 file changed, 72 insertions(+), 60 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 6daa4a727f12..95b168fe76a8 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -5936,6 +5936,75 @@ set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
#endif
+static void
+set_gfc_from_cfi (stmtblock_t *block, tree gfc, tree cfi, tree rank,
+ gfc_symbol *c_sym)
+{
+ tree tmp = gfc_get_cfi_desc_base_addr (cfi);
+ gfc_conv_descriptor_data_set (block, gfc, tmp);
+
+ if (c_sym->attr.allocatable)
+{
+ /* gfc->span = cfi->elem_len. */
+ tmp = fold_convert (gfc_array_index_type,
+ gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
+}
+ else
+{
+ /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
+ ? cfi->dim[0].sm : cfi->elem_len). */
+ tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
+ tree tmp2 = fold_convert (gfc_array_index_type,
+ gfc_get_cfi_desc_elem_len (cfi));
+ tmp = fold_build2_loc (input_location, TRUNC_MOD_EXPR,
+gfc_array_index_type, tmp, tmp2);
+ tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+tmp, gfc_index_zero_node);
+ tmp = build3_loc (input_location, COND_EXPR, gfc_array_index_type, tmp,
+ gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]), tmp2);
+}
+ gfc_conv_descriptor_span_set (block, gfc, tmp);
+
+ /* Calculate offset + set lbound, ubound and stride. */
+ gfc_conv_descriptor_offset_set (block, gfc, gfc_index_zero_node);
+ /* Loop: for (i = 0; i < rank; ++i). */
+ tree idx = gfc_create_var (TREE_TYPE (rank), "idx");
+ /* Loop body. */
+ stmtblock_t loop_body;
+ gfc_init_block (&loop_body);
+ /* gfc->dim[i].lbound = ... */
+ tmp = gfc_get_cfi_dim_lbound (cfi, idx);
+ gfc_conv_descriptor_lbound_set (&loop_body, gfc, idx, tmp);
+
+ /* gfc->dim[i].ubound = gfc->dim[i].lbound + cfi->dim[i].extent - 1. */
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+gfc_conv_descriptor_lbound_get (gfc, idx),
+gfc_index_one_node);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+gfc_get_cfi_dim_extent (cfi, idx), tmp);
+ gfc_conv_descriptor_ubound_set (&loop_body, gfc, idx, tmp);
+
+ /* gfc->dim[i].stride = cfi->dim[i].sm / cfi>elem_len */
+ tmp = gfc_get_cfi_dim_sm (cfi, idx);
+ tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
+gfc_array_index_type, tmp,
+fold_convert (gfc_array_index_type,
+ gfc_get_cfi_desc_elem_len (cfi)));
+ gfc_conv_descriptor_stride_set (&loop_body, gfc, idx, tmp);
+
+ /* gfc->offset -= gfc->dim[i].stride * gfc->dim[i].lbound. */
+ tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+gfc_conv_descriptor_stride_get (gfc, idx),
+gfc_conv_descriptor_lbound_get (gfc, idx));
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+gfc_conv_descriptor_offset_get (gfc), tmp);
+ gfc_conv_descriptor_offset_set (&loop_body, gfc, tmp);
+ /* Generate loop. */
+ gfc_simple_for_loop (block, idx, build_int_cst (TREE_TYPE (idx), 0),
+ rank, LT_EXPR, build_int_cst (TREE_TYPE (idx), 1),
+ gfc_finish_block (&loop_body));
+}
+
/* Provide an interface between gfortran array descriptors and the F2018:18.4
ISO_Fortran_binding array descriptors. */
@@ -6315,8 +6384,10 @@ done:
goto post_call;
gfc_init_block (&block2);
+
if (e->rank == 0)
{
+ gfc_init_block (&block2);
tmp = gfc_get_cfi_desc_base_addr (cfi);
gfc_add_modify (&block, gfc, fold_convert (TREE_TYPE (gfc), tmp));
}
@@ -6325,66 +6396,7 @@ done:
tmp = gfc_get_cfi_desc_base_addr (cfi);
gfc_conv_descriptor_data_set (&block, gfc, tmp);
- if (fsym->attr.allocatable)
- {
- /* gfc->span = cfi->elem_len. */
- tmp = fold_convert (gfc_array_index_type,
- gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]));
- }
- else
- {
- /* gfc->span = ((cfi->dim[0].sm % cfi->elem_len)
- ? cfi->dim[0].sm : cfi->elem_len). */
- tmp = gfc_get_cfi_dim_sm (cfi, gfc_rank_cst[0]);
- tmp2 = fold_convert (gfc_array_index_type,
- gfc_get_cfi_desc_elem_len (cfi
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Refactoring gfc_conv_descriptor_sm_get.
https://gcc.gnu.org/g:7d9a5b709d1f2400ea62c334bff7c9d4436a687c
commit 7d9a5b709d1f2400ea62c334bff7c9d4436a687c
Author: Mikael Morin
Date: Wed Jan 22 21:59:46 2025 +0100
Refactoring gfc_conv_descriptor_sm_get.
Diff:
---
gcc/fortran/trans-array.cc | 11 +++
gcc/fortran/trans-array.h | 1 +
gcc/fortran/trans-expr.cc | 4 +---
3 files changed, 13 insertions(+), 3 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 7357626be9a5..4d08a862c5be 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -589,6 +589,17 @@ gfc_conv_descriptor_extent_get (tree desc, tree dim)
}
+tree
+gfc_conv_descriptor_sm_get (tree desc, tree dim)
+{
+ tree stride = gfc_conv_descriptor_stride_get (desc, dim);
+ tree span = gfc_conv_descriptor_span_get (desc);
+
+ return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ stride, span);
+}
+
+
static int
get_type_info (const bt &type)
{
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 1d694989b4c3..296a8052dd73 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -195,6 +195,7 @@ tree gfc_conv_descriptor_stride_get (tree, tree);
tree gfc_conv_descriptor_lbound_get (tree, tree);
tree gfc_conv_descriptor_ubound_get (tree, tree);
tree gfc_conv_descriptor_extent_get (tree, tree);
+tree gfc_conv_descriptor_sm_get (tree, tree);
tree gfc_conv_descriptor_token (tree);
void gfc_conv_descriptor_data_set (stmtblock_t *, tree, tree);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 84111f5e3d3d..6daa4a727f12 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6262,9 +6262,7 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr
*e, gfc_symbol *fsym)
tmp = gfc_conv_descriptor_extent_get (gfc, idx);
gfc_add_modify (&loop_body, gfc_get_cfi_dim_extent (cfi, idx), tmp);
/* d->dim[n].sm = gfc->dim[i].stride * gfc->span); */
- tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
-gfc_conv_descriptor_stride_get (gfc, idx),
-gfc_conv_descriptor_span_get (gfc));
+ tmp = gfc_conv_descriptor_sm_get (gfc, idx);
gfc_add_modify (&loop_body, gfc_get_cfi_dim_sm (cfi, idx), tmp);
/* Generate loop. */
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation shift descriptor
https://gcc.gnu.org/g:c2ce7393ce79293896ae05dcfff402ffea2c9176
commit c2ce7393ce79293896ae05dcfff402ffea2c9176
Author: Mikael Morin
Date: Tue Jan 21 22:27:02 2025 +0100
Factorisation shift descriptor
Diff:
---
gcc/fortran/trans-array.cc | 117 -
gcc/fortran/trans-array.h | 1 +
gcc/fortran/trans-expr.cc | 82 ++-
3 files changed, 100 insertions(+), 100 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index b05f69fdd874..7afa29746e08 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1198,16 +1198,52 @@ conv_shift_descriptor_lbound (stmtblock_t* block, tree
desc, int dim,
}
-class lb_info
+class lb_info_base
{
public:
+ virtual tree lower_bound (stmtblock_t *block, int dim) const = 0;
+};
+
+
+class lb_info : public lb_info_base
+{
+public:
+ using lb_info_base::lower_bound;
virtual gfc_expr *lower_bound (int dim) const = 0;
+ virtual tree lower_bound (stmtblock_t *block, int dim) const;
};
+tree
+lb_info::lower_bound (stmtblock_t *block, int dim) const
+{
+ gfc_expr *lb_expr = lower_bound(dim);
+
+ if (lb_expr == nullptr)
+return gfc_index_one_node;
+ else
+{
+ gfc_se lb_se;
+
+ gfc_init_se (&lb_se, nullptr);
+ gfc_conv_expr (&lb_se, lb_expr);
+
+ gfc_add_block_to_block (block, &lb_se.pre);
+ tree lb_var = gfc_create_var (gfc_array_index_type, "lower_bound");
+ gfc_add_modify (block, lb_var,
+ fold_convert (gfc_array_index_type, lb_se.expr));
+ gfc_add_block_to_block (block, &lb_se.post);
+
+ return lb_var;
+}
+}
+
+
+
class unset_lb : public lb_info
{
public:
+ using lb_info::lower_bound;
virtual gfc_expr *lower_bound (int) const { return nullptr; }
};
@@ -1218,6 +1254,7 @@ class defined_lb : public lb_info
gfc_expr * const * lower_bounds;
public:
+ using lb_info::lower_bound;
defined_lb (int arg_rank, gfc_expr * const
arg_lower_bounds[GFC_MAX_DIMENSIONS])
: rank(arg_rank), lower_bounds(arg_lower_bounds) { }
virtual gfc_expr *lower_bound (int dim) const { return lower_bounds[dim]; }
@@ -1226,7 +1263,7 @@ public:
static void
conv_shift_descriptor (stmtblock_t *block, tree desc, int rank,
- const lb_info &info)
+ const lb_info_base &info)
{
tree tmp = gfc_conv_descriptor_offset_get (desc);
tree offset_var = gfc_create_var (TREE_TYPE (tmp), "offset");
@@ -1235,26 +1272,7 @@ conv_shift_descriptor (stmtblock_t *block, tree desc,
int rank,
/* Apply a shift of the lbound when supplied. */
for (int dim = 0; dim < rank; ++dim)
{
- gfc_expr *lb_expr = info.lower_bound(dim);
-
- tree lower_bound;
- if (lb_expr == nullptr)
- lower_bound = gfc_index_one_node;
- else
- {
- gfc_se lb_se;
-
- gfc_init_se (&lb_se, nullptr);
- gfc_conv_expr (&lb_se, lb_expr);
-
- gfc_add_block_to_block (block, &lb_se.pre);
- tree lb_var = gfc_create_var (TREE_TYPE (lb_se.expr), "lower_bound");
- gfc_add_modify (block, lb_var, lb_se.expr);
- gfc_add_block_to_block (block, &lb_se.post);
-
- lower_bound = lb_var;
- }
-
+ tree lower_bound = info.lower_bound (block, dim);
conv_shift_descriptor_lbound (block, desc, dim, lower_bound, offset_var);
}
@@ -1337,6 +1355,61 @@ gfc_conv_shift_descriptor (stmtblock_t *block, tree desc,
}
+class dataref_lb : public lb_info_base
+{
+ gfc_array_spec *as;
+ gfc_expr *conv_arg;
+ tree desc;
+
+public:
+ dataref_lb (gfc_array_spec *arg_as, gfc_expr *arg_conv_arg, tree arg_desc)
+: as(arg_as), conv_arg (arg_conv_arg), desc (arg_desc)
+ {}
+ virtual tree lower_bound (stmtblock_t *block, int dim) const;
+};
+
+
+tree
+dataref_lb::lower_bound (stmtblock_t *block, int dim) const
+{
+ tree lbound;
+ if (as && as->lower[dim])
+{
+ gfc_se lbse;
+ gfc_init_se (&lbse, NULL);
+ gfc_conv_expr (&lbse, as->lower[dim]);
+ gfc_add_block_to_block (block, &lbse.pre);
+ lbound = gfc_evaluate_now (lbse.expr, block);
+}
+ else if (as && conv_arg)
+{
+ tree tmp = gfc_get_symbol_decl (conv_arg->symtree->n.sym);
+ lbound = gfc_conv_descriptor_lbound_get (tmp, gfc_rank_cst[dim]);
+}
+ else if (as)
+lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
+ else
+lbound = gfc_index_one_node;
+
+ return fold_convert (gfc_array_index_type, lbound);
+}
+
+
+void
+gfc_conv_shift_descriptor_subarray (stmtblock_t *block, tree desc,
+ gfc_expr *value_expr, gfc_expr *conv_arg)
+{
+ /* Obtain the array spec of full array references. */
+ gfc_array_spec *as;
+ if (conv_arg)
+as = gfc_get_full_arrayspec_from_expr (conv_arg);
+ else
+as = gfc_get_full_arrayspec_from_expr (value_expr);
+
+ conv_shift_descriptor (block, desc, value_expr->rank, dataref_lb (as,
conv
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] utilisation booléen allocatable
https://gcc.gnu.org/g:84be5a435f2a78f8a9ab0bdf5b693a1e0c6b6fd5
commit 84be5a435f2a78f8a9ab0bdf5b693a1e0c6b6fd5
Author: Mikael Morin
Date: Thu Jan 23 21:38:24 2025 +0100
utilisation booléen allocatable
Diff:
---
gcc/fortran/trans-expr.cc | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 95b168fe76a8..518a5a127cf0 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -5938,12 +5938,12 @@ set_dtype_for_unallocated (gfc_se *parmse, gfc_expr *e)
static void
set_gfc_from_cfi (stmtblock_t *block, tree gfc, tree cfi, tree rank,
- gfc_symbol *c_sym)
+ bool allocatable)
{
tree tmp = gfc_get_cfi_desc_base_addr (cfi);
gfc_conv_descriptor_data_set (block, gfc, tmp);
- if (c_sym->attr.allocatable)
+ if (allocatable)
{
/* gfc->span = cfi->elem_len. */
tmp = fold_convert (gfc_array_index_type,
@@ -6396,7 +6396,7 @@ done:
tmp = gfc_get_cfi_desc_base_addr (cfi);
gfc_conv_descriptor_data_set (&block, gfc, tmp);
- set_gfc_from_cfi (&block2, gfc, cfi, rank, fsym);
+ set_gfc_from_cfi (&block2, gfc, cfi, rank, fsym->attr.allocatable);
}
if (e->ts.type == BT_CHARACTER && !e->ts.u.cl->length)
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation set descriptor with shape
https://gcc.gnu.org/g:c3a50c1a8cb83384345d3dc3530fbb9b830d6e85
commit c3a50c1a8cb83384345d3dc3530fbb9b830d6e85
Author: Mikael Morin
Date: Fri Jan 17 21:46:27 2025 +0100
Factorisation set descriptor with shape
Diff:
---
gcc/fortran/trans-array.cc | 78 ++
gcc/fortran/trans-array.h | 2 ++
gcc/fortran/trans-intrinsic.cc | 76 +++-
3 files changed, 85 insertions(+), 71 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 88a2509a5246..b05f69fdd874 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1566,6 +1566,84 @@ copy_descriptor (stmtblock_t *block, tree dest, tree src,
gfc_conv_descriptor_span_set (block, dest, tmp);
}
+
+void
+gfc_set_descriptor_with_shape (stmtblock_t *block, tree desc,
+ tree ptr, gfc_expr *shape,
+ locus *where)
+{
+ /* Set the span field. */
+ tree tmp = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (desc)));
+ tmp = fold_convert (gfc_array_index_type, tmp);
+ gfc_conv_descriptor_span_set (block, desc, tmp);
+
+ /* Set data value, dtype, and offset. */
+ tmp = GFC_TYPE_ARRAY_DATAPTR_TYPE (TREE_TYPE (desc));
+ gfc_conv_descriptor_data_set (block, desc, fold_convert (tmp, ptr));
+ gfc_add_modify (block, gfc_conv_descriptor_dtype (desc),
+ gfc_get_dtype (TREE_TYPE (desc)));
+
+ /* Start scalarization of the bounds, using the shape argument. */
+
+ gfc_ss *shape_ss = gfc_walk_expr (shape);
+ gcc_assert (shape_ss != gfc_ss_terminator);
+ gfc_se shapese;
+ gfc_init_se (&shapese, NULL);
+
+ gfc_loopinfo loop;
+ gfc_init_loopinfo (&loop);
+ gfc_add_ss_to_loop (&loop, shape_ss);
+ gfc_conv_ss_startstride (&loop);
+ gfc_conv_loop_setup (&loop, where);
+ gfc_mark_ss_chain_used (shape_ss, 1);
+
+ gfc_copy_loopinfo_to_se (&shapese, &loop);
+ shapese.ss = shape_ss;
+
+ tree stride = gfc_create_var (gfc_array_index_type, "stride");
+ tree offset = gfc_create_var (gfc_array_index_type, "offset");
+ gfc_add_modify (block, stride, gfc_index_one_node);
+ gfc_add_modify (block, offset, gfc_index_zero_node);
+
+ /* Loop body. */
+ stmtblock_t body;
+ gfc_start_scalarized_body (&loop, &body);
+
+ tree dim = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ loop.loopvar[0], loop.from[0]);
+
+ /* Set bounds and stride. */
+ gfc_conv_descriptor_lbound_set (&body, desc, dim, gfc_index_one_node);
+ gfc_conv_descriptor_stride_set (&body, desc, dim, stride);
+
+ gfc_conv_expr (&shapese, shape);
+ gfc_add_block_to_block (&body, &shapese.pre);
+ gfc_conv_descriptor_ubound_set (&body, desc, dim, shapese.expr);
+ gfc_add_block_to_block (&body, &shapese.post);
+
+ /* Calculate offset. */
+ gfc_add_modify (&body, offset,
+ fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, offset, stride));
+ /* Update stride. */
+ gfc_add_modify (&body, stride,
+ fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, stride,
+ fold_convert (gfc_array_index_type,
+shapese.expr)));
+ /* Finish scalarization loop. */
+ gfc_trans_scalarizing_loops (&loop, &body);
+ gfc_add_block_to_block (block, &loop.pre);
+ gfc_add_block_to_block (block, &loop.post);
+ gfc_cleanup_loop (&loop);
+
+ gfc_add_modify (block, offset,
+ fold_build1_loc (input_location, NEGATE_EXPR,
+ gfc_array_index_type, offset));
+ gfc_conv_descriptor_offset_set (block, desc, offset);
+}
+
+
/* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
void
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 3f39845c898f..05ea68d531ac 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -145,6 +145,8 @@ void gfc_clear_descriptor (stmtblock_t *block, gfc_symbol
*, tree);
void gfc_nullify_descriptor (stmtblock_t *block, gfc_expr *, tree);
void gfc_clear_descriptor (stmtblock_t *block, gfc_symbol *, gfc_expr *, tree);
void gfc_set_scalar_descriptor (stmtblock_t *block, tree, gfc_symbol *,
gfc_expr *, tree);
+void gfc_set_descriptor_with_shape (stmtblock_t *, tree, tree,
+ gfc_expr *, locus *);
/* Get a single array element. */
void gfc_conv_array_ref (gfc_se *, gfc_array_ref *, gfc_expr *, locus *);
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index b6900d734afd..5d77f3d768a6 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -10482,11 +10482,8 @@ conv_isocbinding_subroutine (gfc_code *code)
gfc_se se;
gfc_se cptrse;
gfc_se fptrse;
- gfc_se shapese;
- gfc_ss *shape_ss;
- tree desc, dim, tmp, stride, offset;
- stmtbl
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation initialisation subarray_descriptor
https://gcc.gnu.org/g:41e38348a930505eacdc9386c9fce31a40bdbdb2
commit 41e38348a930505eacdc9386c9fce31a40bdbdb2
Author: Mikael Morin
Date: Tue Jan 21 18:44:41 2025 +0100
Factorisation initialisation subarray_descriptor
Diff:
---
gcc/fortran/trans-expr.cc | 151 --
1 file changed, 78 insertions(+), 73 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index b7d1e3df0613..65b6cd8a4642 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -9418,17 +9418,90 @@ gfc_trans_subarray_assign (tree dest, gfc_component *
cm, gfc_expr * expr)
}
+static void
+set_subarray_descriptor (stmtblock_t *block, tree desc, tree value,
+gfc_expr *value_expr, gfc_expr *conv_arg)
+{
+ if (value_expr->expr_type != EXPR_VARIABLE)
+gfc_conv_descriptor_data_set (block, value,
+ null_pointer_node);
+
+ /* Obtain the array spec of full array references. */
+ gfc_array_spec *as;
+ if (conv_arg)
+as = gfc_get_full_arrayspec_from_expr (conv_arg);
+ else
+as = gfc_get_full_arrayspec_from_expr (value_expr);
+
+ /* Shift the lbound and ubound of temporaries to being unity,
+ rather than zero, based. Always calculate the offset. */
+ tree offset = gfc_conv_descriptor_offset_get (desc);
+ gfc_add_modify (block, offset, gfc_index_zero_node);
+ tree tmp2 = gfc_create_var (gfc_array_index_type, NULL);
+
+ for (int n = 0; n < value_expr->rank; n++)
+{
+ tree span;
+ tree lbound;
+
+ /* Obtain the correct lbound - ISO/IEC TR 15581:2001 page 9.
+TODO It looks as if gfc_conv_expr_descriptor should return
+the correct bounds and that the following should not be
+necessary. This would simplify gfc_conv_intrinsic_bound
+as well. */
+ if (as && as->lower[n])
+ {
+ gfc_se lbse;
+ gfc_init_se (&lbse, NULL);
+ gfc_conv_expr (&lbse, as->lower[n]);
+ gfc_add_block_to_block (block, &lbse.pre);
+ lbound = gfc_evaluate_now (lbse.expr, block);
+ }
+ else if (as && conv_arg)
+ {
+ tree tmp = gfc_get_symbol_decl (conv_arg->symtree->n.sym);
+ lbound = gfc_conv_descriptor_lbound_get (tmp,
+ gfc_rank_cst[n]);
+ }
+ else if (as)
+ lbound = gfc_conv_descriptor_lbound_get (desc,
+ gfc_rank_cst[n]);
+ else
+ lbound = gfc_index_one_node;
+
+ lbound = fold_convert (gfc_array_index_type, lbound);
+
+ /* Shift the bounds and set the offset accordingly. */
+ tree tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]);
+ span = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ tmp, gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n]));
+ tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+span, lbound);
+ gfc_conv_descriptor_ubound_set (block, desc,
+ gfc_rank_cst[n], tmp);
+ gfc_conv_descriptor_lbound_set (block, desc,
+ gfc_rank_cst[n], lbound);
+
+ tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+gfc_conv_descriptor_lbound_get (desc,
+gfc_rank_cst[n]),
+gfc_conv_descriptor_stride_get (desc,
+gfc_rank_cst[n]));
+ gfc_add_modify (block, tmp2, tmp);
+ tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+offset, tmp2);
+ gfc_conv_descriptor_offset_set (block, desc, tmp);
+}
+}
+
+
static tree
gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
gfc_expr * expr)
{
gfc_se se;
stmtblock_t block;
- tree offset;
- int n;
tree tmp;
- tree tmp2;
- gfc_array_spec *as;
gfc_expr *arg = NULL;
gfc_start_block (&block);
@@ -9489,10 +9562,6 @@ gfc_trans_alloc_subarray_assign (tree dest,
gfc_component * cm,
gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &se.post);
- if (expr->expr_type != EXPR_VARIABLE)
-gfc_conv_descriptor_data_set (&block, se.expr,
- null_pointer_node);
-
/* We need to know if the argument of a conversion function is a
variable, so that the correct lower bound can be used. */
if (expr->expr_type == EXPR_FUNCTION
@@ -9502,71 +9571,7 @@ gfc_trans_alloc_subarray_assign (tree dest,
gfc_component * cm,
&& expr->value.function.actual->expr->expr_type == EXPR_VARIABLE)
arg = expr->value.function.actual->expr;
- /* Obtain the array spec of full array references. */
- if (arg)
-as = gfc_get_full_arrayspec_from_expr (arg);
- else
-a
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation set_contiguous_array
https://gcc.gnu.org/g:ccb2dcc879e6c3debbd0e010cfc394cfde504fbc
commit ccb2dcc879e6c3debbd0e010cfc394cfde504fbc
Author: Mikael Morin
Date: Fri Jan 17 17:25:59 2025 +0100
Factorisation set_contiguous_array
Diff:
---
gcc/fortran/trans-array.cc | 57 +++---
1 file changed, 29 insertions(+), 28 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 4f066680dff0..76668d8a3ef1 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -10685,6 +10685,23 @@ gfc_caf_is_dealloc_only (int caf_mode)
}
+static void
+set_contiguous_array (stmtblock_t *block, tree desc, tree size, tree data_ptr)
+{
+ gfc_add_modify (block, gfc_conv_descriptor_dtype (desc),
+ gfc_get_dtype_rank_type (1, TREE_TYPE (desc)));
+ gfc_conv_descriptor_lbound_set (block, desc,
+ gfc_index_zero_node,
+ gfc_index_one_node);
+ gfc_conv_descriptor_stride_set (block, desc,
+ gfc_index_zero_node,
+ gfc_index_one_node);
+ gfc_conv_descriptor_ubound_set (block, desc,
+ gfc_index_zero_node, size);
+ gfc_conv_descriptor_data_set (block, desc, data_ptr);
+}
+
+
/* Recursively traverse an object of derived type, generating code to
deallocate, nullify or copy allocatable components. This is the work horse
function for the functions named in this enum. */
@@ -10945,32 +10962,6 @@ structure_alloc_comps (gfc_symbol * der_type, tree
decl, tree dest,
ubound = build_int_cst (gfc_array_index_type, 1);
}
- /* Treat strings like arrays. Or the other way around, do not
- * generate an additional array layer for scalar components. */
- if (attr->dimension || c->ts.type == BT_CHARACTER)
- {
- cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
-&ubound, 1,
-GFC_ARRAY_ALLOCATABLE, false);
-
- cdesc = gfc_create_var (cdesc, "cdesc");
- DECL_ARTIFICIAL (cdesc) = 1;
-
- gfc_add_modify (&tmpblock, gfc_conv_descriptor_dtype (cdesc),
- gfc_get_dtype_rank_type (1, tmp));
- gfc_conv_descriptor_lbound_set (&tmpblock, cdesc,
- gfc_index_zero_node,
- gfc_index_one_node);
- gfc_conv_descriptor_stride_set (&tmpblock, cdesc,
- gfc_index_zero_node,
- gfc_index_one_node);
- gfc_conv_descriptor_ubound_set (&tmpblock, cdesc,
- gfc_index_zero_node, ubound);
- }
- else
- /* Prevent warning. */
- cdesc = NULL_TREE;
-
if (attr->dimension)
{
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (comp)))
@@ -10993,13 +10984,23 @@ structure_alloc_comps (gfc_symbol * der_type, tree
decl, tree dest,
gfc_add_block_to_block (&tmpblock, &se.pre);
}
+ /* Treat strings like arrays. Or the other way around, do not
+ * generate an additional array layer for scalar components. */
if (attr->dimension || c->ts.type == BT_CHARACTER)
- gfc_conv_descriptor_data_set (&tmpblock, cdesc, comp);
+ {
+ cdesc = gfc_get_array_type_bounds (tmp, 1, 0, &gfc_index_one_node,
+&ubound, 1,
+GFC_ARRAY_ALLOCATABLE, false);
+
+ cdesc = gfc_create_var (cdesc, "cdesc");
+ DECL_ARTIFICIAL (cdesc) = 1;
+
+ set_contiguous_array (&tmpblock, cdesc, ubound, comp);
+ }
else
cdesc = comp;
tree fndecl;
-
fndecl = build_call_expr_loc (input_location,
gfor_fndecl_co_broadcast, 5,
gfc_build_addr_expr
(pvoid_type_node,cdesc),
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation set_contiguous_array
https://gcc.gnu.org/g:b5834effc49cacae162a35ff2deafe3a9bbc9d1c commit b5834effc49cacae162a35ff2deafe3a9bbc9d1c Author: Mikael Morin Date: Fri Jan 17 17:48:42 2025 +0100 Factorisation set_contiguous_array Diff: --- gcc/fortran/trans-array.cc | 13 + 1 file changed, 1 insertion(+), 12 deletions(-) diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 76668d8a3ef1..88a2509a5246 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -11148,21 +11148,10 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, cdesc = gfc_create_var (cdesc, "cdesc"); DECL_ARTIFICIAL (cdesc) = 1; - gfc_add_modify (&dealloc_block, gfc_conv_descriptor_dtype (cdesc), - gfc_get_dtype_rank_type (1, tmp)); - gfc_conv_descriptor_lbound_set (&dealloc_block, cdesc, - gfc_index_zero_node, - gfc_index_one_node); - gfc_conv_descriptor_stride_set (&dealloc_block, cdesc, - gfc_index_zero_node, - gfc_index_one_node); - gfc_conv_descriptor_ubound_set (&dealloc_block, cdesc, - gfc_index_zero_node, ubound); - if (attr->dimension) comp = gfc_conv_descriptor_data_get (comp); - gfc_conv_descriptor_data_set (&dealloc_block, cdesc, comp); + set_contiguous_array (&dealloc_block, cdesc, ubound, comp); /* Now call the deallocator. */ vtab = gfc_find_vtab (&c->ts);
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Renseignement token par gfc_set_descriptor_from_scalar.
https://gcc.gnu.org/g:96c395b57efb83588e592fca055aac91794c0919
commit 96c395b57efb83588e592fca055aac91794c0919
Author: Mikael Morin
Date: Wed Feb 5 15:12:25 2025 +0100
Renseignement token par gfc_set_descriptor_from_scalar.
Diff:
---
gcc/fortran/trans-array.cc | 27 ---
gcc/fortran/trans-array.h | 2 +-
gcc/fortran/trans-expr.cc | 15 +++
3 files changed, 32 insertions(+), 12 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 531281049646..c09b9bdab155 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -682,6 +682,7 @@ public:
virtual bool set_span () const { return false; }
virtual bool set_token () const { return true; }
virtual tree get_data_value () const { return NULL_TREE; }
+ virtual tree get_caf_token () const { return null_pointer_node; }
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); }
};
@@ -751,22 +752,24 @@ private:
bool initialisation;
gfc_typespec *ts;
tree value;
+ tree caf_token;
bool use_tree_type_;
bool clear_token;
tree get_elt_type () const;
public:
scalar_value(gfc_typespec &arg_ts, tree 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) { }
+: initialisation(true), ts(&arg_ts), value(arg_value), caf_token
(NULL_TREE), use_tree_type_ (false), clear_token(true) { }
+ scalar_value(tree arg_value, tree arg_caf_token)
+: initialisation(true), ts(nullptr), value(arg_value), caf_token
(arg_caf_token), 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;
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 bool set_token () const { return clear_token || caf_token !=
NULL_TREE; }
+ virtual tree get_caf_token () const;
virtual bt get_type_type (const gfc_typespec &) const;
virtual tree get_length (gfc_typespec *ts) const;
};
@@ -838,6 +841,16 @@ scalar_value::get_length (gfc_typespec * type_info) const
return size;
}
+tree
+scalar_value::get_caf_token () const
+{
+ if (set_token ()
+ && caf_token != NULL_TREE)
+return caf_token;
+ else
+return modify_info::get_caf_token ();
+}
+
static tree
build_dtype (gfc_typespec *ts, int rank, const symbol_attribute &,
@@ -933,7 +946,7 @@ get_descriptor_init (tree type, gfc_typespec *ts, int rank,
tree token_field = gfc_advance_chain (fields,
CAF_TOKEN_FIELD - (!dim_present));
tree token_value = fold_convert (TREE_TYPE (token_field),
- null_pointer_node);
+ init.get_caf_token ());
CONSTRUCTOR_APPEND_ELT (v, token_field, token_value);
}
@@ -1430,11 +1443,11 @@ 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)
+ symbol_attribute *attr, tree caf_token)
{
init_struct (block, desc,
get_descriptor_init (TREE_TYPE (desc), nullptr, 0, attr,
- scalar_value (scalar)));
+ scalar_value (scalar, caf_token)));
}
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 97cf7f8cb41f..2dad79aa9993 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 *);
+symbol_attribute *, tree = NULL_TREE);
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 39bd7178c3c0..13a1ec1e8fe3 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -883,14 +883,20 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
gfc_symbol *fsym,
/* Now set the data field. */
ctree = gfc_
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Sauvegarde factorisation set_descriptor_from_scalar
https://gcc.gnu.org/g:34baff548d9dc0913b69f129deb42a51686257db
commit 34baff548d9dc0913b69f129deb42a51686257db
Author: Mikael Morin
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 d6e7c9829ff2..90eafe7ffe18 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);
@@ -600,7 +601,7 @@ gfc_conv_descriptor_sm_get (tree desc, tree dim)
}
-static int
+static bt
get_type_info (const bt &type)
{
switch (type)
@@ -611,11 +612,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;
@@ -672,9 +675,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
@@ -698,8 +707,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
{
@@ -729,23 +744,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 ();
+ gf
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation gfc_conv_shift_descriptor.
https://gcc.gnu.org/g:f05298303aa01ad801cc056e79e94e50f205aec7
commit f05298303aa01ad801cc056e79e94e50f205aec7
Author: Mikael Morin
Date: Thu Feb 6 18:02:37 2025 +0100
Factorisation gfc_conv_shift_descriptor.
Correction régression allocated_4.f90
Diff:
---
gcc/fortran/trans-array.cc | 103 -
1 file changed, 55 insertions(+), 48 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 2cca5e211469..09947b6fa602 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1477,28 +1477,32 @@ gfc_build_null_descriptor (tree type)
static void
conv_shift_descriptor_lbound (stmtblock_t* block, tree from_desc, tree
to_desc, int dim,
- tree new_lbound, tree offset)
+ tree new_lbound, tree offset, bool
relative_offset)
{
- tree ubound, lbound, stride;
- tree diff, offs_diff;
-
new_lbound = fold_convert (gfc_array_index_type, new_lbound);
- lbound = gfc_conv_descriptor_lbound_get (from_desc, gfc_rank_cst[dim]);
- ubound = gfc_conv_descriptor_ubound_get (from_desc, gfc_rank_cst[dim]);
- stride = gfc_conv_descriptor_stride_get (from_desc, gfc_rank_cst[dim]);
+ tree lbound = gfc_conv_descriptor_lbound_get (from_desc, gfc_rank_cst[dim]);
+ tree ubound = gfc_conv_descriptor_ubound_get (from_desc, gfc_rank_cst[dim]);
+ tree stride = gfc_conv_descriptor_stride_get (from_desc, gfc_rank_cst[dim]);
/* Get difference (new - old) by which to shift stuff. */
- diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- new_lbound, lbound);
+ tree diff = fold_build2_loc (input_location, MINUS_EXPR,
gfc_array_index_type,
+ new_lbound, lbound);
/* Shift ubound and offset accordingly. This has to be done before
updating the lbound, as they depend on the lbound expression! */
ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
ubound, diff);
gfc_conv_descriptor_ubound_set (block, to_desc, gfc_rank_cst[dim], ubound);
+
+ tree offs_diff;
+ if (relative_offset)
+offs_diff = diff;
+ else
+offs_diff = lbound;
+
offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
- diff, stride);
+ offs_diff, stride);
tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
offset, offs_diff);
gfc_add_modify (block, offset, tmp);
@@ -1515,6 +1519,7 @@ class lb_info_base
{
public:
virtual tree lower_bound (stmtblock_t *block, int dim) const = 0;
+ virtual bool relative_offset () const { return true; }
};
@@ -1575,62 +1580,64 @@ public:
static void
-conv_shift_descriptor (stmtblock_t *block, tree desc, int rank,
+conv_shift_descriptor (stmtblock_t *block, tree src, tree dest, int rank,
const lb_info_base &info)
{
- tree tmp = gfc_conv_descriptor_offset_get (desc);
- tree offset_var = gfc_create_var (TREE_TYPE (tmp), "offset");
- gfc_add_modify (block, offset_var, tmp);
+ if (src != dest)
+{
+ tree tmp = gfc_conv_descriptor_data_get (src);
+ gfc_conv_descriptor_data_set (block, dest, tmp);
+}
+
+ tree offset_var = gfc_create_var (gfc_array_index_type, "offset");
+ tree init_offset;
+ if (info.relative_offset ())
+init_offset = gfc_conv_descriptor_offset_get (src);
+ else
+init_offset = gfc_index_zero_node;
+ gfc_add_modify (block, offset_var, init_offset);
/* Apply a shift of the lbound when supplied. */
for (int dim = 0; dim < rank; ++dim)
{
tree lower_bound = info.lower_bound (block, dim);
- conv_shift_descriptor_lbound (block, desc, desc, dim, lower_bound,
offset_var);
+ conv_shift_descriptor_lbound (block, src, dest, dim, lower_bound,
offset_var,
+ info.relative_offset ());
}
- gfc_conv_descriptor_offset_set (block, desc, offset_var);
+ gfc_conv_descriptor_offset_set (block, dest, offset_var);
+}
+
+
+static void
+conv_shift_descriptor (stmtblock_t *block, tree desc, int rank,
+ const lb_info_base &info)
+{
+ conv_shift_descriptor (block, desc, desc, rank, info);
}
-class conditional_lb
+class cond_descr_lb : public lb_info_base
{
+ tree desc;
tree cond;
public:
- conditional_lb (tree arg_cond)
-: cond (arg_cond) { }
+ cond_descr_lb (tree arg_desc, tree arg_cond)
+: desc (arg_desc), cond (arg_cond) { }
- tree lower_bound (tree src, int n) const {
-tree lbound = gfc_conv_descriptor_lbound_get (src, gfc_rank_cst[n]);
-lbound = fold_build3_loc (input_location, COND_EXPR,
- gfc_array_index_type, cond,
- gfc_index_one_node, lbound);
-return lbound;
- }
+ virtual tree lower_bound (stmtblock_t *block, int dim) const;
+
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation gfc_conv_shift_descriptor
https://gcc.gnu.org/g:7307f6176e05224b7628261375c7a3f0f64e74a8
commit 7307f6176e05224b7628261375c7a3f0f64e74a8
Author: Mikael Morin
Date: Thu Feb 6 17:16:13 2025 +0100
Factorisation gfc_conv_shift_descriptor
Correction compil'
Correction régression allocated_4.f90
Diff:
---
gcc/fortran/trans-array.cc | 113 -
1 file changed, 51 insertions(+), 62 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index c09b9bdab155..2cca5e211469 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1476,7 +1476,7 @@ gfc_build_null_descriptor (tree type)
specified. This also updates ubound and offset accordingly. */
static void
-conv_shift_descriptor_lbound (stmtblock_t* block, tree desc, int dim,
+conv_shift_descriptor_lbound (stmtblock_t* block, tree from_desc, tree
to_desc, int dim,
tree new_lbound, tree offset)
{
tree ubound, lbound, stride;
@@ -1484,9 +1484,9 @@ conv_shift_descriptor_lbound (stmtblock_t* block, tree
desc, int dim,
new_lbound = fold_convert (gfc_array_index_type, new_lbound);
- lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
- ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
- stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
+ lbound = gfc_conv_descriptor_lbound_get (from_desc, gfc_rank_cst[dim]);
+ ubound = gfc_conv_descriptor_ubound_get (from_desc, gfc_rank_cst[dim]);
+ stride = gfc_conv_descriptor_stride_get (from_desc, gfc_rank_cst[dim]);
/* Get difference (new - old) by which to shift stuff. */
diff = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
@@ -1496,7 +1496,7 @@ conv_shift_descriptor_lbound (stmtblock_t* block, tree
desc, int dim,
updating the lbound, as they depend on the lbound expression! */
ubound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
ubound, diff);
- gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
+ gfc_conv_descriptor_ubound_set (block, to_desc, gfc_rank_cst[dim], ubound);
offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
diff, stride);
tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
@@ -1504,7 +1504,10 @@ conv_shift_descriptor_lbound (stmtblock_t* block, tree
desc, int dim,
gfc_add_modify (block, offset, tmp);
/* Finally set lbound to value we want. */
- gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
+ gfc_conv_descriptor_lbound_set (block, to_desc, gfc_rank_cst[dim],
new_lbound);
+
+ if (from_desc != to_desc)
+gfc_conv_descriptor_stride_set (block, to_desc, gfc_rank_cst[dim], stride);
}
@@ -1583,13 +1586,54 @@ conv_shift_descriptor (stmtblock_t *block, tree desc,
int rank,
for (int dim = 0; dim < rank; ++dim)
{
tree lower_bound = info.lower_bound (block, dim);
- conv_shift_descriptor_lbound (block, desc, dim, lower_bound, offset_var);
+ conv_shift_descriptor_lbound (block, desc, desc, dim, lower_bound,
offset_var);
}
gfc_conv_descriptor_offset_set (block, desc, offset_var);
}
+class conditional_lb
+{
+ tree cond;
+public:
+ conditional_lb (tree arg_cond)
+: cond (arg_cond) { }
+
+ tree lower_bound (tree src, int n) const {
+tree lbound = gfc_conv_descriptor_lbound_get (src, gfc_rank_cst[n]);
+lbound = fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type, cond,
+ gfc_index_one_node, lbound);
+return lbound;
+ }
+};
+
+
+static void
+gfc_conv_shift_descriptor (stmtblock_t *block, tree dest, tree src,
+ int rank, const conditional_lb &lb)
+{
+ tree tmp = gfc_conv_descriptor_data_get (src);
+ gfc_conv_descriptor_data_set (block, dest, tmp);
+
+ tree offset_var = gfc_create_var (gfc_array_index_type, "offset");
+ gfc_add_modify (block, offset_var, gfc_index_zero_node);
+
+ for (int n = 0 ; n < rank; n++)
+{
+ tree lbound;
+
+ lbound = lb.lower_bound (dest, n);
+ lbound = gfc_evaluate_now (lbound, block);
+
+ conv_shift_descriptor_lbound (block, src, dest, n, lbound, offset_var);
+}
+
+ gfc_conv_descriptor_offset_set (block, dest, offset_var);
+}
+
+
void
gfc_conv_shift_descriptor (stmtblock_t* block, tree desc, int rank)
{
@@ -1859,61 +1903,6 @@ gfc_conv_remap_descriptor (stmtblock_t *block, tree
dest, tree src,
}
-class conditional_lb
-{
- tree cond;
-public:
- conditional_lb (tree arg_cond)
-: cond (arg_cond) { }
-
- tree lower_bound (tree src, int n) const {
-tree lbound = gfc_conv_descriptor_lbound_get (src, gfc_rank_cst[n]);
-lbound = fold_build3_loc (input_location, COND_EXPR,
- gfc_array_index_type, cond,
- gfc_i
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Utilisation de la méthode de nullification pour nullifier un pointeur
https://gcc.gnu.org/g:b68e4d2ef22d8fe82d628a320c6577d1d0a946dd
commit b68e4d2ef22d8fe82d628a320c6577d1d0a946dd
Author: Mikael Morin
Date: Wed Dec 18 19:04:41 2024 +0100
Utilisation de la méthode de nullification pour nullifier un pointeur
Correction régression modifiable_p
Correction dump
Ajout assertion
Correction assertion même type
Diff:
---
gcc/fortran/trans-array.cc | 96 ++---
gcc/fortran/trans-array.h | 1 +
gcc/fortran/trans-expr.cc | 35 -
gcc/testsuite/gfortran.dg/class_allocate_14.f90 | 2 +-
4 files changed, 106 insertions(+), 28 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index cdbff27d82ca..4c237b561aa6 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -545,9 +545,9 @@ gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree
desc,
static int
-get_type_info (const gfc_typespec &ts)
+get_type_info (const bt &type)
{
- switch (ts.type)
+ switch (type)
{
case BT_INTEGER:
case BT_LOGICAL:
@@ -558,7 +558,7 @@ get_type_info (const gfc_typespec &ts)
case BT_CLASS:
case BT_VOID:
case BT_UNSIGNED:
- return ts.type;
+ return type;
case BT_PROCEDURE:
case BT_ASSUMED:
@@ -613,11 +613,34 @@ get_size_info (gfc_typespec &ts)
}
-class init_info
+class modify_info
{
public:
+ virtual bool is_initialization () const { return false; }
virtual bool initialize_data () const { return false; }
virtual tree get_data_value () const { return NULL_TREE; }
+};
+
+class nullification : public modify_info
+{
+ virtual bool initialize_data () const { return true; }
+ virtual tree get_data_value () const { return null_pointer_node; }
+ /*
+private:
+ gfc_typespec &ts;
+
+public:
+ null_init(gfc_typespec &arg_ts) : ts(arg_ts) { }
+ virtual bool initialize_data () const { return true; }
+ virtual tree get_data_value () const { return null_pointer_node; }
+ virtual gfc_typespec *get_type () const { return &ts; }
+ */
+};
+
+class init_info : public modify_info
+{
+public:
+ virtual bool is_initialization () const { return true; }
virtual gfc_typespec *get_type () const { return nullptr; }
};
@@ -638,13 +661,13 @@ public:
}
};
-class nullification : public init_info
+class null_init : public init_info
{
private:
gfc_typespec &ts;
public:
- nullification(gfc_typespec &arg_ts) : ts(arg_ts) { }
+ null_init(gfc_typespec &arg_ts) : ts(arg_ts) { }
virtual bool initialize_data () const { return true; }
virtual tree get_data_value () const { return null_pointer_node; }
virtual gfc_typespec *get_type () const { return &ts; }
@@ -700,13 +723,12 @@ build_dtype (gfc_typespec &ts, int rank, const
symbol_attribute &,
CONSTRUCTOR_APPEND_ELT (v, rank_field, rank_val);
}
- if (type_info->type != BT_CLASS)
-{
- 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));
- CONSTRUCTOR_APPEND_ELT (v, type_info_field, type_info_val);
-}
+ 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));
+ CONSTRUCTOR_APPEND_ELT (v, type_info_field, type_info_val);
return build_constructor (type, v);
}
@@ -715,8 +737,8 @@ build_dtype (gfc_typespec &ts, int rank, const
symbol_attribute &,
/* Build a null array descriptor constructor. */
vec *
-get_descriptor_init (tree type, gfc_typespec &ts, int rank,
-const symbol_attribute &attr, const init_info &init)
+get_descriptor_init (tree type, gfc_typespec *ts, int rank,
+const symbol_attribute *attr, const modify_info &init)
{
vec *v = nullptr;
@@ -732,11 +754,15 @@ get_descriptor_init (tree type, gfc_typespec &ts, int
rank,
CONSTRUCTOR_APPEND_ELT (v, data_field, data_value);
}
- tree dtype_field = gfc_advance_chain (fields, DTYPE_FIELD);
- tree dtype_value = build_dtype (ts, rank, attr, init);
- CONSTRUCTOR_APPEND_ELT (v, dtype_field, dtype_value);
+ if (init.is_initialization ())
+{
+ tree dtype_field = gfc_advance_chain (fields, DTYPE_FIELD);
+ tree dtype_value = build_dtype (*ts, rank, *attr,
+ static_cast (init));
+ CONSTRUCTOR_APPEND_ELT (v, dtype_field, dtype_value);
+}
- if (flag_coarray == GFC_FCOARRAY_LIB && attr.codimension)
+ if (flag_coarray == GFC_FCOARRAY_LIB && attr->codimension)
{
/* Declare the variable static so its array descriptor stays present
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation shift descriptor
https://gcc.gnu.org/g:7421792ba1ee3c272b294ac19a85bc43ad73e3c7
commit 7421792ba1ee3c272b294ac19a85bc43ad73e3c7
Author: Mikael Morin
Date: Thu Jan 16 14:35:14 2025 +0100
Factorisation shift descriptor
Diff:
---
gcc/fortran/trans-array.cc | 6 +++---
gcc/fortran/trans-array.h | 1 +
gcc/fortran/trans-stmt.cc | 6 +-
3 files changed, 5 insertions(+), 8 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index ec0badd0dc33..ecdaad3f9575 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1257,8 +1257,8 @@ conv_shift_descriptor (stmtblock_t *block, tree desc, int
rank,
}
-static void
-conv_shift_descriptor (stmtblock_t* block, tree desc, int rank)
+void
+gfc_conv_shift_descriptor (stmtblock_t* block, tree desc, int rank)
{
conv_shift_descriptor (block, desc, rank, unset_lb ());
}
@@ -10103,7 +10103,7 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr,
bool g77,
gfc_init_block (&block);
if (maybe_shift && !keep_descriptor_lower_bound (expr))
- conv_shift_descriptor (&block, se->expr, expr->rank);
+ gfc_conv_shift_descriptor (&block, se->expr, expr->rank);
bool assumed_rank_fsym;
if (fsym
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 571322ae11ff..378afb9617a3 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -216,6 +216,7 @@ tree gfc_get_cfi_dim_sm (tree, tree);
/* Shift lower bound of descriptor, updating ubound and offset. */
void gfc_conv_shift_descriptor_lbound (stmtblock_t*, tree, int, tree);
void gfc_conv_shift_descriptor (stmtblock_t*, tree, const gfc_array_ref &);
+void gfc_conv_shift_descriptor (stmtblock_t*, tree, int);
void gfc_conv_shift_descriptor (stmtblock_t*, tree, tree, int, tree);
/* Add pre-loop scalarization code for intrinsic functions which require
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index e7da8fea3b24..01fb8d91007f 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -2007,16 +2007,12 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block
*block)
if ((!sym->assoc->variable && !cst_array_ctor)
|| !whole_array)
{
- int dim;
-
if (whole_array)
gfc_add_modify (&se.pre, desc, se.expr);
/* The generated descriptor has lower bound zero (as array
temporary), shift bounds so we get lower bounds of 1. */
- for (dim = 0; dim < e->rank; ++dim)
- gfc_conv_shift_descriptor_lbound (&se.pre, desc,
- dim, gfc_index_one_node);
+ gfc_conv_shift_descriptor (&se.pre, desc, e->rank);
}
/* If this is a subreference array pointer associate name use the
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation gfc_conv_remap_descriptor
https://gcc.gnu.org/g:7ed00263a569c00bf6bf52ea343e677b873e0e2f
commit 7ed00263a569c00bf6bf52ea343e677b873e0e2f
Author: Mikael Morin
Date: Sat Jan 4 21:36:13 2025 +0100
Factorisation gfc_conv_remap_descriptor
Correction régression pointer_remapping_5
Diff:
---
gcc/fortran/trans-array.cc | 119 +++
gcc/fortran/trans-expr.cc | 124 +++--
gcc/fortran/trans.h| 2 +
3 files changed, 129 insertions(+), 116 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 5d56a12ebf71..898930634ad1 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1332,6 +1332,125 @@ gfc_conv_shift_descriptor (stmtblock_t *block, tree
desc,
}
+void
+gfc_conv_remap_descriptor (stmtblock_t *block, tree dest, tree src,
+ int src_rank, const gfc_array_spec &as)
+{
+ int dest_rank = gfc_descriptor_rank (dest);
+
+ /* Set dtype. */
+ tree dtype = gfc_conv_descriptor_dtype (dest);
+ tree tmp = gfc_get_dtype (TREE_TYPE (src));
+ gfc_add_modify (block, dtype, tmp);
+
+ /* Copy data pointer. */
+ tree data = gfc_conv_descriptor_data_get (src);
+ gfc_conv_descriptor_data_set (block, dest, data);
+
+ /* Copy the span. */
+ tree span;
+ if (VAR_P (src)
+ && GFC_DECL_PTR_ARRAY_P (src))
+span = gfc_conv_descriptor_span_get (src);
+ else
+{
+ tmp = TREE_TYPE (src);
+ tmp = TYPE_SIZE_UNIT (gfc_get_element_type (tmp));
+ span = fold_convert (gfc_array_index_type, tmp);
+}
+ gfc_conv_descriptor_span_set (block, dest, span);
+
+ /* Copy offset but adjust it such that it would correspond
+ to a lbound of zero. */
+ if (src_rank == -1)
+gfc_conv_descriptor_offset_set (block, dest,
+ gfc_index_zero_node);
+ else
+{
+ tree offs = gfc_conv_descriptor_offset_get (src);
+ for (int dim = 0; dim < src_rank; ++dim)
+ {
+ tree stride = gfc_conv_descriptor_stride_get (src,
+ gfc_rank_cst[dim]);
+ tree lbound = gfc_conv_descriptor_lbound_get (src,
+ gfc_rank_cst[dim]);
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+gfc_array_index_type, stride,
+lbound);
+ offs = fold_build2_loc (input_location, PLUS_EXPR,
+ gfc_array_index_type, offs, tmp);
+ }
+ gfc_conv_descriptor_offset_set (block, dest, offs);
+}
+ /* Set the bounds as declared for the LHS and calculate strides as
+ well as another offset update accordingly. */
+ tree stride = gfc_conv_descriptor_stride_get (src,
+ gfc_rank_cst[0]);
+ for (int dim = 0; dim < dest_rank; ++dim)
+{
+ gfc_se lower_se;
+ gfc_se upper_se;
+
+ gcc_assert (as.lower[dim] && as.upper[dim]);
+
+ /* Convert declared bounds. */
+ gfc_init_se (&lower_se, NULL);
+ gfc_init_se (&upper_se, NULL);
+ gfc_conv_expr (&lower_se, as.lower[dim]);
+ gfc_conv_expr (&upper_se, as.upper[dim]);
+
+ gfc_add_block_to_block (block, &lower_se.pre);
+ gfc_add_block_to_block (block, &upper_se.pre);
+
+ tree lbound = fold_convert (gfc_array_index_type, lower_se.expr);
+ tree ubound = fold_convert (gfc_array_index_type, upper_se.expr);
+
+ lbound = gfc_evaluate_now (lbound, block);
+ ubound = gfc_evaluate_now (ubound, block);
+
+ gfc_add_block_to_block (block, &lower_se.post);
+ gfc_add_block_to_block (block, &upper_se.post);
+
+ /* Set bounds in descriptor. */
+ gfc_conv_descriptor_lbound_set (block, dest,
+ gfc_rank_cst[dim], lbound);
+ gfc_conv_descriptor_ubound_set (block, dest,
+ gfc_rank_cst[dim], ubound);
+
+ /* Set stride. */
+ stride = gfc_evaluate_now (stride, block);
+ gfc_conv_descriptor_stride_set (block, dest,
+ gfc_rank_cst[dim], stride);
+
+ /* Update offset. */
+ tree offs = gfc_conv_descriptor_offset_get (dest);
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+gfc_array_index_type, lbound, stride);
+ offs = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, offs, tmp);
+ offs = gfc_evaluate_now (offs, block);
+ gfc_conv_descriptor_offset_set (block, dest, offs);
+
+ /* Update stride. */
+ tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ stride = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, stride, tmp);
+}
+}
+
+
+void
+gfc_conv_remap_descriptor (stmtblock_t *block, tree dest, tree src,
+ int src_rank, const gfc_array_ref &ar)
+{
+ g
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Extraction fonction fcncall_realloc_result
https://gcc.gnu.org/g:ed6fee22d9c29ebee21ce323726fb14cfb8d6ed1
commit ed6fee22d9c29ebee21ce323726fb14cfb8d6ed1
Author: Mikael Morin
Date: Thu Jan 9 21:38:39 2025 +0100
Extraction fonction fcncall_realloc_result
Correction variable inutilisée
Correction régression coarray dummy_3
Correction régression dummy_3
Diff:
---
gcc/fortran/trans-array.cc | 64 ++
gcc/fortran/trans-array.h | 1 +
gcc/fortran/trans-expr.cc | 52 +++--
3 files changed, 80 insertions(+), 37 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 898930634ad1..7d43a8c000d3 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1451,6 +1451,70 @@ gfc_conv_remap_descriptor (stmtblock_t *block, tree
dest, tree src,
}
+class conditional_lb
+{
+ tree cond;
+public:
+ conditional_lb (tree arg_cond)
+: cond (arg_cond) { }
+
+ tree lower_bound (tree src, int n) const {
+tree lbound = gfc_conv_descriptor_lbound_get (src, gfc_rank_cst[n]);
+lbound = fold_build3_loc (input_location, COND_EXPR,
+ gfc_array_index_type, cond,
+ gfc_index_one_node, lbound);
+return lbound;
+ }
+};
+
+
+static void
+gfc_conv_shift_descriptor (stmtblock_t *block, tree dest, tree src,
+ int rank, const conditional_lb &lb)
+{
+ tree tmp = gfc_conv_descriptor_data_get (src);
+ gfc_conv_descriptor_data_set (block, dest, tmp);
+
+ tree offset = gfc_index_zero_node;
+ for (int n = 0 ; n < rank; n++)
+{
+ tree lbound;
+
+ lbound = lb.lower_bound (dest, n);
+ lbound = gfc_evaluate_now (lbound, block);
+
+ tmp = gfc_conv_descriptor_ubound_get (src, gfc_rank_cst[n]);
+ tmp = fold_build2_loc (input_location, PLUS_EXPR,
+gfc_array_index_type, tmp, lbound);
+ gfc_conv_descriptor_lbound_set (block, dest,
+ gfc_rank_cst[n], lbound);
+ gfc_conv_descriptor_ubound_set (block, dest,
+ gfc_rank_cst[n], tmp);
+
+ /* Set stride and accumulate the offset. */
+ tmp = gfc_conv_descriptor_stride_get (src, gfc_rank_cst[n]);
+ gfc_conv_descriptor_stride_set (block, dest,
+ gfc_rank_cst[n], tmp);
+ tmp = fold_build2_loc (input_location, MULT_EXPR,
+gfc_array_index_type, lbound, tmp);
+ offset = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, offset, tmp);
+ offset = gfc_evaluate_now (offset, block);
+}
+
+ gfc_conv_descriptor_offset_set (block, dest, offset);
+}
+
+
+void
+gfc_conv_shift_descriptor (stmtblock_t *block, tree dest, tree src,
+ int rank, tree zero_cond)
+{
+ gfc_conv_shift_descriptor (block, dest, src, rank,
+conditional_lb (zero_cond));
+}
+
+
static bool
keep_descriptor_lower_bound (gfc_expr *e)
{
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 8df55c2c00a5..571322ae11ff 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -216,6 +216,7 @@ tree gfc_get_cfi_dim_sm (tree, tree);
/* Shift lower bound of descriptor, updating ubound and offset. */
void gfc_conv_shift_descriptor_lbound (stmtblock_t*, tree, int, tree);
void gfc_conv_shift_descriptor (stmtblock_t*, tree, const gfc_array_ref &);
+void gfc_conv_shift_descriptor (stmtblock_t*, tree, tree, int, tree);
/* Add pre-loop scalarization code for intrinsic functions which require
special handling. */
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index c50b1e05cdbd..77e8a55af457 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -832,6 +832,9 @@ gfc_get_vptr_from_expr (tree expr)
int
gfc_descriptor_rank (tree descriptor)
{
+ if (TREE_TYPE (descriptor) != NULL_TREE)
+return GFC_TYPE_ARRAY_RANK (TREE_TYPE (descriptor));
+
tree dim = gfc_get_descriptor_dimension (descriptor);
tree dim_type = TREE_TYPE (dim);
gcc_assert (TREE_CODE (dim_type) == ARRAY_TYPE);
@@ -916,8 +919,17 @@ gfc_class_array_data_assign (stmtblock_t *block, tree
lhs_desc, tree rhs_desc,
type = TREE_TYPE (tmp);
else
{
- gcc_assert (TREE_TYPE (tmp) == TREE_TYPE (tmp2));
- type = TREE_TYPE (tmp);
+ int corank = GFC_TYPE_ARRAY_CORANK (TREE_TYPE (lhs_desc));
+ int corank2 = GFC_TYPE_ARRAY_CORANK (TREE_TYPE (rhs_desc));
+ if (corank > 0 && corank2 == 0)
+ type = TREE_TYPE (tmp2);
+ else if (corank2 > 0 && corank == 0)
+ type = TREE_TYPE (tmp);
+ else
+ {
+ gcc_assert (TREE_TYPE (tmp) == TREE_TYPE (tmp2));
+ type = TREE_TYPE (tmp);
+ }
}
tmp = build4_loc (input_location, ARRAY_RANGE_REF, type, tmp,
@@ -11595,7 +11607,6 @@ fcncall_realloc_result (g
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Introduction gfc_copy_sequence_descriptor
https://gcc.gnu.org/g:6d1a550acfb35381deea5afbd424a7e79852f5b1
commit 6d1a550acfb35381deea5afbd424a7e79852f5b1
Author: Mikael Morin
Date: Tue Dec 31 15:27:35 2024 +0100
Introduction gfc_copy_sequence_descriptor
Correction régression sizeof_6
Diff:
---
gcc/fortran/trans-array.cc | 39 ++-
gcc/fortran/trans-expr.cc | 44
gcc/fortran/trans.h| 1 +
3 files changed, 59 insertions(+), 25 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 4c237b561aa6..5d56a12ebf71 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -9901,32 +9901,21 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr,
bool g77,
if (maybe_shift && !keep_descriptor_lower_bound (expr))
conv_shift_descriptor (&block, se->expr, expr->rank);
+ bool assumed_rank_fsym;
+ if (fsym
+ && ((fsym->ts.type == BT_CLASS
+ && CLASS_DATA (fsym)->as
+ && CLASS_DATA (fsym)->as->type == AS_ASSUMED_RANK)
+ || (fsym->ts.type != BT_CLASS
+ && fsym->as
+ && fsym->as->type == AS_ASSUMED_RANK)))
+ assumed_rank_fsym = true;
+ else
+ assumed_rank_fsym = false;
+
tmp = gfc_class_data_get (ctree);
- if (expr->rank > 1 && CLASS_DATA (fsym)->as->rank != expr->rank
- && CLASS_DATA (fsym)->as->type == AS_EXPLICIT && !no_pack)
- {
- tree arr = gfc_create_var (TREE_TYPE (tmp), "parm");
- gfc_conv_descriptor_data_set (&block, arr,
- gfc_conv_descriptor_data_get (
- se->expr));
- gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
- gfc_index_zero_node);
- gfc_conv_descriptor_ubound_set (
- &block, arr, gfc_index_zero_node,
- gfc_conv_descriptor_size (se->expr, expr->rank));
- gfc_conv_descriptor_stride_set (
- &block, arr, gfc_index_zero_node,
- gfc_conv_descriptor_stride_get (se->expr, gfc_index_zero_node));
- gfc_add_modify (&block, gfc_conv_descriptor_dtype (arr),
- gfc_conv_descriptor_dtype (se->expr));
- gfc_add_modify (&block, gfc_conv_descriptor_rank (arr),
- build_int_cst (signed_char_type_node, 1));
- gfc_conv_descriptor_span_set (&block, arr,
- gfc_conv_descriptor_span_get (arr));
- gfc_conv_descriptor_offset_set (&block, arr, gfc_index_zero_node);
- se->expr = arr;
- }
- gfc_class_array_data_assign (&block, tmp, se->expr, true);
+ gfc_copy_sequence_descriptor (block, tmp, se->expr,
+ assumed_rank_fsym);
/* Handle optional. */
if (fsym && fsym->attr.optional && sym && sym->attr.optional)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 003754cdad6f..5dff9692f0ba 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -846,6 +846,50 @@ descriptor_rank (tree descriptor)
}
+void
+gfc_copy_sequence_descriptor (stmtblock_t &block, tree lhs_desc, tree rhs_desc,
+ bool assumed_rank_lhs)
+{
+ int lhs_rank = descriptor_rank (lhs_desc);
+ int rhs_rank = descriptor_rank (rhs_desc);
+ tree desc;
+
+ if (assumed_rank_lhs || lhs_rank == rhs_rank)
+desc = rhs_desc;
+ else
+{
+ tree arr = gfc_create_var (TREE_TYPE (lhs_desc), "parm");
+ gfc_conv_descriptor_data_set (&block, arr,
+ gfc_conv_descriptor_data_get (rhs_desc));
+ gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
+ gfc_index_zero_node);
+ tree size = gfc_conv_descriptor_size (rhs_desc, rhs_rank);
+ gfc_conv_descriptor_ubound_set (&block, arr, gfc_index_zero_node, size);
+ gfc_conv_descriptor_stride_set (
+ &block, arr, gfc_index_zero_node,
+ gfc_conv_descriptor_stride_get (rhs_desc, gfc_index_zero_node));
+ for (int i = 1; i < lhs_rank; i++)
+ {
+ gfc_conv_descriptor_lbound_set (&block, arr, gfc_rank_cst[i],
+ gfc_index_zero_node);
+ gfc_conv_descriptor_ubound_set (&block, arr, gfc_rank_cst[i],
+ gfc_index_zero_node);
+ gfc_conv_descriptor_stride_set (&block, arr, gfc_rank_cst[i], size);
+ }
+ gfc_add_modify (&block, gfc_conv_descriptor_dtype (arr),
+ gfc_conv_descriptor_dtype (rhs_desc));
+ gfc_add_modify (&block, gfc_conv_descriptor_rank (arr),
+ build_int_cst (signed_cha
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Refactor conv_shift_descriptor
https://gcc.gnu.org/g:a6d12d1f09654a5d3038b6042e645dd9da4c84a5
commit a6d12d1f09654a5d3038b6042e645dd9da4c84a5
Author: Mikael Morin
Date: Thu Jan 16 15:28:38 2025 +0100
Refactor conv_shift_descriptor
Correction régressions
Correction régression gfc_conv_expr_descriptor
Diff:
---
gcc/fortran/trans-array.cc | 31 +--
gcc/fortran/trans-array.h | 1 -
2 files changed, 17 insertions(+), 15 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index ecdaad3f9575..bf11689cf3dd 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1165,16 +1165,15 @@ gfc_build_null_descriptor (tree type)
/* Modify a descriptor such that the lbound of a given dimension is the value
specified. This also updates ubound and offset accordingly. */
-void
-gfc_conv_shift_descriptor_lbound (stmtblock_t* block, tree desc,
- int dim, tree new_lbound)
+static void
+conv_shift_descriptor_lbound (stmtblock_t* block, tree desc, int dim,
+ tree new_lbound, tree offset)
{
- tree offs, ubound, lbound, stride;
+ tree ubound, lbound, stride;
tree diff, offs_diff;
new_lbound = fold_convert (gfc_array_index_type, new_lbound);
- offs = gfc_conv_descriptor_offset_get (desc);
lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
@@ -1190,9 +1189,9 @@ gfc_conv_shift_descriptor_lbound (stmtblock_t* block,
tree desc,
gfc_conv_descriptor_ubound_set (block, desc, gfc_rank_cst[dim], ubound);
offs_diff = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
diff, stride);
- offs = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- offs, offs_diff);
- gfc_conv_descriptor_offset_set (block, desc, offs);
+ tree tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ offset, offs_diff);
+ gfc_add_modify (block, offset, tmp);
/* Finally set lbound to value we want. */
gfc_conv_descriptor_lbound_set (block, desc, gfc_rank_cst[dim], new_lbound);
@@ -1229,6 +1228,10 @@ static void
conv_shift_descriptor (stmtblock_t *block, tree desc, int rank,
const lb_info &info)
{
+ tree tmp = gfc_conv_descriptor_offset_get (desc);
+ tree offset_var = gfc_create_var (TREE_TYPE (tmp), "offset");
+ gfc_add_modify (block, offset_var, tmp);
+
/* Apply a shift of the lbound when supplied. */
for (int dim = 0; dim < rank; ++dim)
{
@@ -1252,8 +1255,10 @@ conv_shift_descriptor (stmtblock_t *block, tree desc,
int rank,
lower_bound = lb_var;
}
- gfc_conv_shift_descriptor_lbound (block, desc, dim, lower_bound);
+ conv_shift_descriptor_lbound (block, desc, dim, lower_bound, offset_var);
}
+
+ gfc_conv_descriptor_offset_set (block, desc, offset_var);
}
@@ -9225,7 +9230,6 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
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)
@@ -9251,7 +9255,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
}
if (!se->direct_byref)
-unlimited_polymorphic = UNLIMITED_POLY (expr);
+se->unlimited_polymorphic = UNLIMITED_POLY (expr);
/* Special case things we know we can pass easily. */
switch (expr->expr_type)
@@ -9655,9 +9659,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
gfc_get_array_span (desc, expr)));
}
-
- set_descriptor (&se->pre, parm, desc, expr, loop.dimen, codim,
- ss, info, loop.from, loop.to, unlimited_polymorphic,
+ set_descriptor (&loop.pre, parm, desc, expr, loop.dimen, codim,
+ ss, info, loop.from, loop.to, se->unlimited_polymorphic,
!se->data_not_needed, subref_array_target);
desc = parm;
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 378afb9617a3..3f39845c898f 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -214,7 +214,6 @@ tree gfc_get_cfi_dim_sm (tree, tree);
/* Shift lower bound of descriptor, updating ubound and offset. */
-void gfc_conv_shift_descriptor_lbound (stmtblock_t*, tree, int, tree);
void gfc_conv_shift_descriptor (stmtblock_t*, tree, const gfc_array_ref &);
void gfc_conv_shift_descriptor (stmtblock_t*, tree, int);
void gfc_conv_shift_descriptor (stmtblock_t*, tree, tree, int, tree);
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation copie gfc_conv_expr_descriptor
https://gcc.gnu.org/g:82413c99dc41ba8b632e751540ba26d97ea67ceb
commit 82413c99dc41ba8b632e751540ba26d97ea67ceb
Author: Mikael Morin
Date: Wed Jan 15 17:51:21 2025 +0100
Factorisation copie gfc_conv_expr_descriptor
Diff:
---
gcc/fortran/trans-array.cc | 37 ++---
1 file changed, 22 insertions(+), 15 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 7d43a8c000d3..097a9a0d860a 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -8989,6 +8989,26 @@ is_explicit_coarray (gfc_expr *expr)
return cas && cas->cotype == AS_EXPLICIT;
}
+
+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);
+}
+
/* 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
@@ -9123,21 +9143,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
if (full && !transposed_dims (ss))
{
if (se->direct_byref && !se->byref_noassign)
- {
- /* Copy the descriptor for pointer assignments. */
- gfc_add_modify (&se->pre, se->expr, desc);
-
- /* Add any offsets from subreferences. */
- gfc_get_dataptr_offset (&se->pre, se->expr, desc, NULL_TREE,
- subref_array_target, expr);
-
- /* and set the span field. */
- if (ss_info->expr->ts.type == BT_CHARACTER)
- tmp = gfc_conv_descriptor_span_get (desc);
- else
- tmp = gfc_get_array_span (desc, expr);
- gfc_conv_descriptor_span_set (&se->pre, se->expr, tmp);
- }
+ copy_descriptor (&se->pre, se->expr, desc, expr,
+subref_array_target);
else if (se->want_pointer)
{
/* We pass full arrays directly. This means that pointers and
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Déplacement gfc_set_gfc_from_cfi
https://gcc.gnu.org/g:47b6338824d5cf0658bd91e24bd956dcf2bfaca3
commit 47b6338824d5cf0658bd91e24bd956dcf2bfaca3
Author: Mikael Morin
Date: Thu Jan 30 21:27:40 2025 +0100
Déplacement gfc_set_gfc_from_cfi
Correction compil'
Diff:
---
gcc/fortran/trans-array.cc | 258 +
gcc/fortran/trans-array.h | 3 +
gcc/fortran/trans-expr.cc | 218 --
gcc/fortran/trans.h| 3 -
4 files changed, 241 insertions(+), 241 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 455c9bcd76cc..d6e7c9829ff2 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1466,6 +1466,26 @@ gfc_conv_shift_descriptor_subarray (stmtblock_t *block,
tree desc,
}
+int
+gfc_descriptor_rank (tree descriptor)
+{
+ if (TREE_TYPE (descriptor) != NULL_TREE)
+return GFC_TYPE_ARRAY_RANK (TREE_TYPE (descriptor));
+
+ tree dim = gfc_get_descriptor_dimension (descriptor);
+ tree dim_type = TREE_TYPE (dim);
+ gcc_assert (TREE_CODE (dim_type) == ARRAY_TYPE);
+ tree idx_type = TYPE_DOMAIN (dim_type);
+ gcc_assert (TREE_CODE (idx_type) == INTEGER_TYPE);
+ gcc_assert (integer_zerop (TYPE_MIN_VALUE (idx_type)));
+ tree idx_max = TYPE_MAX_VALUE (idx_type);
+ if (idx_max == NULL_TREE)
+return GFC_MAX_DIMENSIONS;
+ wide_int max = wi::to_wide (idx_max);
+ return max.to_shwi () + 1;
+}
+
+
void
gfc_conv_remap_descriptor (stmtblock_t *block, tree dest, tree src,
int src_rank, const gfc_array_spec &as)
@@ -1835,26 +1855,6 @@ gfc_set_descriptor_from_scalar (stmtblock_t *block, tree
desc, tree scalar,
gfc_conv_descriptor_data_set (block, desc, tmp);
}
-int
-gfc_descriptor_rank (tree descriptor)
-{
- if (TREE_TYPE (descriptor) != NULL_TREE)
-return GFC_TYPE_ARRAY_RANK (TREE_TYPE (descriptor));
-
- tree dim = gfc_get_descriptor_dimension (descriptor);
- tree dim_type = TREE_TYPE (dim);
- gcc_assert (TREE_CODE (dim_type) == ARRAY_TYPE);
- tree idx_type = TYPE_DOMAIN (dim_type);
- gcc_assert (TREE_CODE (idx_type) == INTEGER_TYPE);
- gcc_assert (integer_zerop (TYPE_MIN_VALUE (idx_type)));
- tree idx_max = TYPE_MAX_VALUE (idx_type);
- if (idx_max == NULL_TREE)
-return GFC_MAX_DIMENSIONS;
- wide_int max = wi::to_wide (idx_max);
- return max.to_shwi () + 1;
-}
-
-
void
gfc_copy_sequence_descriptor (stmtblock_t &block, tree lhs_desc, tree rhs_desc,
bool assumed_rank_lhs)
@@ -1899,6 +1899,224 @@ gfc_copy_sequence_descriptor (stmtblock_t &block, tree
lhs_desc, tree rhs_desc,
}
+void
+gfc_set_gfc_from_cfi (stmtblock_t *unconditional_block,
+ stmtblock_t *conditional_block, tree gfc, tree cfi,
+ tree rank, gfc_symbol *gfc_sym,
+ bool init_static, bool contiguous_gfc, bool
contiguous_cfi)
+{
+ tree tmp = gfc_get_cfi_desc_base_addr (cfi);
+ gfc_conv_descriptor_data_set (unconditional_block, gfc, tmp);
+
+ if (init_static)
+{
+ /* gfc->dtype = ... (from declaration, not from cfi). */
+ tree etype = gfc_get_element_type (TREE_TYPE (gfc));
+ gfc_add_modify (unconditional_block, gfc_conv_descriptor_dtype (gfc),
+ gfc_get_dtype_rank_type (gfc_sym->as->rank, etype));
+
+ if (gfc_sym->as->type == AS_ASSUMED_RANK)
+ gfc_add_modify (unconditional_block,
+ gfc_conv_descriptor_rank (gfc), rank);
+}
+
+ if (gfc_sym && gfc_sym->ts.type == BT_ASSUMED)
+{
+ /* For type(*), take elem_len + dtype.type from the actual argument. */
+ gfc_add_modify (unconditional_block, gfc_conv_descriptor_elem_len (gfc),
+ gfc_get_cfi_desc_elem_len (cfi));
+ tree cond;
+ tree ctype = gfc_get_cfi_desc_type (cfi);
+ ctype = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (ctype),
+ ctype, build_int_cst (TREE_TYPE (ctype),
+CFI_type_mask));
+ tree type = gfc_conv_descriptor_type (gfc);
+
+ /* if (CFI_type_cptr) BT_VOID else BT_UNKNOWN */
+ /* Note: BT_VOID is could also be CFI_type_funcptr, but assume c_ptr. */
+ cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
ctype,
+ build_int_cst (TREE_TYPE (ctype), CFI_type_cptr));
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, type,
+build_int_cst (TREE_TYPE (type), BT_VOID));
+ tree tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+ type,
+ build_int_cst (TREE_TYPE (type),
BT_UNKNOWN));
+ tmp2 = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
+ tmp, tmp2);
+ /* if (CFI_type_struct) BT_DERIVED else < tmp2 > */
+ cond = fold_build2_loc (input_location, EQ_
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation set_descriptor_from_scalar dans gfc_conv_scalar_to_descriptor
https://gcc.gnu.org/g:01b40a54c893abe13bf134397e2f1651e4088d58
commit 01b40a54c893abe13bf134397e2f1651e4088d58
Author: Mikael Morin
Date: Wed Jan 29 19:05:04 2025 +0100
Factorisation set_descriptor_from_scalar dans gfc_conv_scalar_to_descriptor
Correction régression pr49213.f90
Correction régression associated_assumed_rank.f90
Diff:
---
gcc/fortran/trans-expr.cc | 67 +++
1 file changed, 38 insertions(+), 29 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 091e1417faed..860224066167 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -174,46 +174,61 @@ gfc_conv_null_array_descriptor (gfc_se *se, gfc_symbol
*sym, gfc_expr *expr)
void
set_descriptor_from_scalar (stmtblock_t *block, tree desc, tree scalar,
- gfc_expr *scalar_expr, bool is_class,
+ symbol_attribute scalar_attr, bool is_class,
tree cond_optional)
{
- tree type = get_scalar_to_descriptor_type (scalar,
-gfc_expr_attr (scalar_expr));
+ tree type = get_scalar_to_descriptor_type (scalar, scalar_attr);
if (POINTER_TYPE_P (type))
type = TREE_TYPE (type);
- tree dtype_val = gfc_get_dtype (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);
- tree tmp;
- if (is_class)
+ gfc_conv_descriptor_span_set (block, desc, integer_zero_node);
+
+ if (CONSTANT_CLASS_P (scalar))
{
- tmp = gfc_class_data_get (scalar);
- if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
- tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+ tree tmp;
+ tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
+ gfc_add_modify (block, tmp, scalar);
+ scalar = tmp;
}
- else if (cond_optional)
+
+ 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 (scalar),
- cond_optional, scalar,
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+ cond_optional, tmp,
fold_convert (TREE_TYPE (scalar),
null_pointer_node));
}
- else
-tmp = scalar;
gfc_conv_descriptor_data_set (block, desc, tmp);
}
+
tree
gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar, symbol_attribute attr)
{
- tree desc, type, etype;
+ tree desc, type;
type = get_scalar_to_descriptor_type (scalar, attr);
- etype = TREE_TYPE (scalar);
desc = gfc_create_var (type, "desc");
DECL_ARTIFICIAL (desc) = 1;
@@ -224,15 +239,9 @@ gfc_conv_scalar_to_descriptor (gfc_se *se, tree scalar,
symbol_attribute attr)
gfc_add_modify (&se->pre, tmp, scalar);
scalar = tmp;
}
- if (!POINTER_TYPE_P (TREE_TYPE (scalar)))
-scalar = gfc_build_addr_expr (NULL_TREE, scalar);
- else if (TREE_TYPE (etype) && TREE_CODE (TREE_TYPE (etype)) == ARRAY_TYPE)
-etype = TREE_TYPE (etype);
- gfc_add_modify (&se->pre, gfc_conv_descriptor_dtype (desc),
- gfc_get_dtype_rank_type (0, etype));
- gfc_conv_descriptor_data_set (&se->pre, desc, scalar);
- gfc_conv_descriptor_span_set (&se->pre, desc,
- gfc_conv_descriptor_elem_len (desc));
+
+ set_descriptor_from_scalar (&se->pre, desc, scalar, attr,
+ false, NULL_TREE);
/* Copy pointer address back - but only if it could have changed and
if the actual argument is a pointer and not, e.g., NULL(). */
@@ -1082,8 +1091,8 @@ 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)
set_descriptor_from_scalar (&parmse->pre, ctree,
- parmse->expr, e, false,
- cond_optional);
+ parmse->expr, gfc_expr_attr (e),
+ false, cond_optional);
else
{
tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
@@ -1458,8 +1467,8 @@ 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)
- set_descriptor_from_scalar (&block, ctree, parmse->expr, e,
- true, NULL_TREE);
+ set_descriptor_from_scalar (&block, ctree, pa
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Update dump match count
https://gcc.gnu.org/g:08384499e15f84f573c888267a125e6ae15cd904
commit 08384499e15f84f573c888267a125e6ae15cd904
Author: Mikael Morin
Date: Thu Jan 30 16:53:48 2025 +0100
Update dump match count
Diff:
---
gcc/testsuite/gfortran.dg/coarray_collectives_18.f90 | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/gcc/testsuite/gfortran.dg/coarray_collectives_18.f90
b/gcc/testsuite/gfortran.dg/coarray_collectives_18.f90
index c83899de0e5b..a1f2a76ff73e 100644
--- a/gcc/testsuite/gfortran.dg/coarray_collectives_18.f90
+++ b/gcc/testsuite/gfortran.dg/coarray_collectives_18.f90
@@ -33,5 +33,5 @@ end program
! This lead to access to non exsitant memory in opencoarrays.
! In single image mode just checking for reduced number of
! descriptors is possible, i.e., execute always works.
-! { dg-final { scan-tree-dump-times "desc\\.\[0-9\]+" 12 "original" } }
+! { dg-final { scan-tree-dump-times "desc\\.\[0-9\]+" 10 "original" } }
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Déplacement gfc_copy_sequence_descriptor
https://gcc.gnu.org/g:d29279433aa2fbcd57c06a7a9ca84e09a35c5bba
commit d29279433aa2fbcd57c06a7a9ca84e09a35c5bba
Author: Mikael Morin
Date: Thu Jan 30 21:21:39 2025 +0100
Déplacement gfc_copy_sequence_descriptor
Correction erreur compil'
Diff:
---
gcc/fortran/trans-array.cc | 64 ++
gcc/fortran/trans-array.h | 1 +
gcc/fortran/trans-expr.cc | 64 --
gcc/fortran/trans.h| 1 -
4 files changed, 65 insertions(+), 65 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index a1fb41fc9354..455c9bcd76cc 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1835,6 +1835,70 @@ gfc_set_descriptor_from_scalar (stmtblock_t *block, tree
desc, tree scalar,
gfc_conv_descriptor_data_set (block, desc, tmp);
}
+int
+gfc_descriptor_rank (tree descriptor)
+{
+ if (TREE_TYPE (descriptor) != NULL_TREE)
+return GFC_TYPE_ARRAY_RANK (TREE_TYPE (descriptor));
+
+ tree dim = gfc_get_descriptor_dimension (descriptor);
+ tree dim_type = TREE_TYPE (dim);
+ gcc_assert (TREE_CODE (dim_type) == ARRAY_TYPE);
+ tree idx_type = TYPE_DOMAIN (dim_type);
+ gcc_assert (TREE_CODE (idx_type) == INTEGER_TYPE);
+ gcc_assert (integer_zerop (TYPE_MIN_VALUE (idx_type)));
+ tree idx_max = TYPE_MAX_VALUE (idx_type);
+ if (idx_max == NULL_TREE)
+return GFC_MAX_DIMENSIONS;
+ wide_int max = wi::to_wide (idx_max);
+ return max.to_shwi () + 1;
+}
+
+
+void
+gfc_copy_sequence_descriptor (stmtblock_t &block, tree lhs_desc, tree rhs_desc,
+ bool assumed_rank_lhs)
+{
+ int lhs_rank = gfc_descriptor_rank (lhs_desc);
+ int rhs_rank = gfc_descriptor_rank (rhs_desc);
+ tree desc;
+
+ if (assumed_rank_lhs || lhs_rank == rhs_rank)
+desc = rhs_desc;
+ else
+{
+ tree arr = gfc_create_var (TREE_TYPE (lhs_desc), "parm");
+ gfc_conv_descriptor_data_set (&block, arr,
+ gfc_conv_descriptor_data_get (rhs_desc));
+ gfc_conv_descriptor_lbound_set (&block, arr, gfc_index_zero_node,
+ gfc_index_zero_node);
+ tree size = gfc_conv_descriptor_size (rhs_desc, rhs_rank);
+ gfc_conv_descriptor_ubound_set (&block, arr, gfc_index_zero_node, size);
+ gfc_conv_descriptor_stride_set (
+ &block, arr, gfc_index_zero_node,
+ gfc_conv_descriptor_stride_get (rhs_desc, gfc_index_zero_node));
+ for (int i = 1; i < lhs_rank; i++)
+ {
+ gfc_conv_descriptor_lbound_set (&block, arr, gfc_rank_cst[i],
+ gfc_index_zero_node);
+ gfc_conv_descriptor_ubound_set (&block, arr, gfc_rank_cst[i],
+ gfc_index_zero_node);
+ gfc_conv_descriptor_stride_set (&block, arr, gfc_rank_cst[i], size);
+ }
+ gfc_add_modify (&block, gfc_conv_descriptor_dtype (arr),
+ gfc_conv_descriptor_dtype (rhs_desc));
+ gfc_add_modify (&block, gfc_conv_descriptor_rank (arr),
+ build_int_cst (signed_char_type_node, lhs_rank));
+ gfc_conv_descriptor_span_set (&block, arr,
+ gfc_conv_descriptor_span_get (arr));
+ gfc_conv_descriptor_offset_set (&block, arr, gfc_index_zero_node);
+ desc = arr;
+}
+
+ gfc_class_array_data_assign (&block, lhs_desc, desc, true);
+}
+
+
/* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 691231f66903..124020a53858 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -150,6 +150,7 @@ void gfc_set_descriptor_with_shape (stmtblock_t *, tree,
tree,
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);
+void gfc_copy_sequence_descriptor (stmtblock_t &, tree, tree, bool);
/* Get a single array element. */
void gfc_conv_array_ref (gfc_se *, gfc_array_ref *, gfc_expr *, locus *);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 2ece9d369d80..205c49949626 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -800,70 +800,6 @@ gfc_get_vptr_from_expr (tree expr)
}
-int
-gfc_descriptor_rank (tree descriptor)
-{
- if (TREE_TYPE (descriptor) != NULL_TREE)
-return GFC_TYPE_ARRAY_RANK (TREE_TYPE (descriptor));
-
- tree dim = gfc_get_descriptor_dimension (descriptor);
- tree dim_type = TREE_TYPE (dim);
- gcc_assert (TREE_CODE (dim_type) == ARRAY_TYPE);
- tree idx_type = TYPE_DOMAIN (dim_type);
- gcc_assert (TREE_CODE (idx_type) == INTEGER_TYPE);
- gcc_assert (integer_zerop (TYPE_MIN_VALUE (idx_type)));
- tree idx_max = TYPE_MAX_VALUE (idx_type);
- if (idx_max == NULL_TREE)
-return GFC_MAX_DIMENSIONS;
- wide_int max = wi::to_wide
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Introduction gfc_conv_descriptor_extent_get
https://gcc.gnu.org/g:55a2a1029553f80b56f5a8c5ef8a5935c0dd1088
commit 55a2a1029553f80b56f5a8c5ef8a5935c0dd1088
Author: Mikael Morin
Date: Wed Jan 22 19:02:13 2025 +0100
Introduction gfc_conv_descriptor_extent_get
Diff:
---
gcc/fortran/trans-array.cc | 84 ++
gcc/fortran/trans-array.h | 1 +
gcc/fortran/trans-expr.cc | 6 +---
3 files changed, 50 insertions(+), 41 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 7afa29746e08..7357626be9a5 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -544,6 +544,51 @@ gfc_conv_descriptor_ubound_set (stmtblock_t *block, tree
desc,
}
+/* Calculate the size of a given array dimension from the bounds. This
+ is simply (ubound - lbound + 1) if this expression is positive
+ or 0 if it is negative (pick either one if it is zero). Optionally
+ (if or_expr is present) OR the (expression != 0) condition to it. */
+
+static tree
+conv_array_extent_dim (tree lbound, tree ubound, bool maybe_negative, tree*
or_expr)
+{
+ tree res;
+ tree cond;
+
+ /* Calculate (ubound - lbound + 1). */
+ res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+ubound, lbound);
+ res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
+gfc_index_one_node);
+
+ /* Check whether the size for this dimension is negative. */
+ if (maybe_negative)
+{
+ cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res,
+ gfc_index_zero_node);
+ res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type,
cond,
+gfc_index_zero_node, res);
+}
+
+ /* Build OR expression. */
+ if (maybe_negative && or_expr)
+*or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ logical_type_node, *or_expr, cond);
+
+ return res;
+}
+
+
+tree
+gfc_conv_descriptor_extent_get (tree desc, tree dim)
+{
+ tree ubound = gfc_conv_descriptor_ubound_get (desc, dim);
+ tree lbound = gfc_conv_descriptor_lbound_get (desc, dim);
+
+ return conv_array_extent_dim (lbound, ubound, false, NULL);
+}
+
+
static int
get_type_info (const bt &type)
{
@@ -7111,30 +7156,9 @@ gfc_set_delta (gfc_loopinfo *loop)
tree
gfc_conv_array_extent_dim (tree lbound, tree ubound, tree* or_expr)
{
- tree res;
- tree cond;
-
- /* Calculate (ubound - lbound + 1). */
- res = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
-ubound, lbound);
- res = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, res,
-gfc_index_one_node);
-
- /* Check whether the size for this dimension is negative. */
- cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, res,
- gfc_index_zero_node);
- res = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, cond,
-gfc_index_zero_node, res);
-
- /* Build OR expression. */
- if (or_expr)
-*or_expr = fold_build2_loc (input_location, TRUTH_OR_EXPR,
- logical_type_node, *or_expr, cond);
-
- return res;
+ return conv_array_extent_dim (lbound, ubound, true, or_expr);
}
-
/* For an array descriptor, get the total number of elements. This is just
the product of the extents along from_dim to to_dim. */
@@ -7148,14 +7172,7 @@ gfc_conv_descriptor_size_1 (tree desc, int from_dim, int
to_dim)
for (dim = from_dim; dim < to_dim; ++dim)
{
- tree lbound;
- tree ubound;
- tree extent;
-
- lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
- ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
-
- extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ tree extent = gfc_conv_descriptor_extent_get (desc, gfc_rank_cst[dim]);
res = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
res, extent);
}
@@ -10543,12 +10560,7 @@ gfc_full_array_size (stmtblock_t *block, tree decl,
int rank)
tree nelems;
tree tmp;
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,
-nelems, tmp);
- tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
-tmp, gfc_index_one_node);
+ tmp = gfc_conv_descriptor_extent_get (decl, idx);
tmp = gfc_evaluate_now (tmp, block);
nelems = gfc_conv_descriptor_stride_get (decl, idx);
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index f9988a5fd109..1d694989b4c3 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -194,6 +194,7 @@ tree gfc_get_descriptor_
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Séparation motifs dump assumed_rank_12.f90
https://gcc.gnu.org/g:cd99fadb64da650e93e666dbf2eb7c4b15a6dc5b
commit cd99fadb64da650e93e666dbf2eb7c4b15a6dc5b
Author: Mikael Morin
Date: Wed Feb 5 11:57:09 2025 +0100
Séparation motifs dump assumed_rank_12.f90
Diff:
---
gcc/testsuite/gfortran.dg/assumed_rank_12.f90 | 6 +-
1 file changed, 5 insertions(+), 1 deletion(-)
diff --git a/gcc/testsuite/gfortran.dg/assumed_rank_12.f90
b/gcc/testsuite/gfortran.dg/assumed_rank_12.f90
index 873498f82d76..cacfb7ed52af 100644
--- a/gcc/testsuite/gfortran.dg/assumed_rank_12.f90
+++ b/gcc/testsuite/gfortran.dg/assumed_rank_12.f90
@@ -16,5 +16,9 @@ function f() result(res)
end function f
end
-! { dg-final { scan-tree-dump " = f \\(\\);.*desc.0.dtype = .*;.*desc.0.data =
.void .. D.*;.*sub \\(&desc.0\\);.*D.*= .integer.kind=4. .. desc.0.data;"
"original" } }
+! { dg-final { scan-tree-dump " = f \\(\\);" "original" } }
+! { dg-final { scan-tree-dump "desc.0.dtype = .*;" "original" } }
+! { dg-final { scan-tree-dump "desc.0.data = .void .. D.*;" "original" } }
+! { dg-final { scan-tree-dump "sub \\(&desc.0\\);" "original" } }
+! { dg-final { scan-tree-dump "D.*= .integer.kind=4. .. desc.0.data;"
"original" } }
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Suppression code redondant
https://gcc.gnu.org/g:0aef3272bde76847317337411e9b7b75e74dc101
commit 0aef3272bde76847317337411e9b7b75e74dc101
Author: Mikael Morin
Date: Thu Jan 30 20:57:37 2025 +0100
Suppression code redondant
Diff:
---
gcc/fortran/trans-expr.cc | 8
1 file changed, 8 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 860224066167..18d54d2a1f93 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -193,14 +193,6 @@ set_descriptor_from_scalar (stmtblock_t *block, tree desc,
tree scalar,
gfc_conv_descriptor_span_set (block, desc, integer_zero_node);
- if (CONSTANT_CLASS_P (scalar))
-{
- tree tmp;
- tmp = gfc_create_var (TREE_TYPE (scalar), "scalar");
- gfc_add_modify (block, tmp, scalar);
- scalar = tmp;
-}
-
tree tmp;
if (is_class)
tmp = gfc_class_data_get (scalar);
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation set_descriptor_from_scalar conv_derived_to_class
https://gcc.gnu.org/g:c3d8cf0e081de45c9a2f5d2d80ff8675f5e4614a
commit c3d8cf0e081de45c9a2f5d2d80ff8675f5e4614a
Author: Mikael Morin
Date: Wed Jan 29 18:22:29 2025 +0100
Factorisation set_descriptor_from_scalar conv_derived_to_class
Diff:
---
gcc/fortran/trans-expr.cc | 42 +++---
1 file changed, 23 insertions(+), 19 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 6afb344245f2..091e1417faed 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -174,7 +174,8 @@ gfc_conv_null_array_descriptor (gfc_se *se, gfc_symbol
*sym, gfc_expr *expr)
void
set_descriptor_from_scalar (stmtblock_t *block, tree desc, tree scalar,
- gfc_expr *scalar_expr)
+ gfc_expr *scalar_expr, bool is_class,
+ tree cond_optional)
{
tree type = get_scalar_to_descriptor_type (scalar,
gfc_expr_attr (scalar_expr));
@@ -185,9 +186,22 @@ set_descriptor_from_scalar (stmtblock_t *block, tree desc,
tree scalar,
tree dtype_ref = gfc_conv_descriptor_dtype (desc);
gfc_add_modify (block, dtype_ref, dtype_val);
- tree tmp = gfc_class_data_get (scalar);
- if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
-tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+ tree tmp;
+ if (is_class)
+{
+ tmp = gfc_class_data_get (scalar);
+ if (!POINTER_TYPE_P (TREE_TYPE (tmp)))
+ tmp = gfc_build_addr_expr (NULL_TREE, tmp);
+}
+ else if (cond_optional)
+{
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (scalar),
+ cond_optional, scalar,
+ fold_convert (TREE_TYPE (scalar),
+ null_pointer_node));
+}
+ else
+tmp = scalar;
gfc_conv_descriptor_data_set (block, desc, tmp);
}
@@ -1067,20 +1081,9 @@ 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)
- {
- tree type;
- type = get_scalar_to_descriptor_type (parmse->expr,
- gfc_expr_attr (e));
- gfc_add_modify (&parmse->pre, gfc_conv_descriptor_dtype (ctree),
- gfc_get_dtype (type));
- if (optional)
- parmse->expr = build3_loc (input_location, COND_EXPR,
- TREE_TYPE (parmse->expr),
- cond_optional, parmse->expr,
- fold_convert (TREE_TYPE
(parmse->expr),
-null_pointer_node));
- gfc_conv_descriptor_data_set (&parmse->pre, ctree, parmse->expr);
- }
+ set_descriptor_from_scalar (&parmse->pre, ctree,
+ parmse->expr, e, false,
+ cond_optional);
else
{
tmp = fold_convert (TREE_TYPE (ctree), parmse->expr);
@@ -1455,7 +1458,8 @@ 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)
- set_descriptor_from_scalar (&block, ctree, parmse->expr, e);
+ set_descriptor_from_scalar (&block, ctree, parmse->expr, e,
+ true, NULL_TREE);
else
gfc_class_array_data_assign (&block, ctree, parmse->expr, false);
}
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Déplacement shift descriptor vers gfc_conv_array_parameter
https://gcc.gnu.org/g:063c0014407236e53fa5c3734cab2f3fec5fa03f
commit 063c0014407236e53fa5c3734cab2f3fec5fa03f
Author: Mikael Morin
Date: Tue Dec 17 17:27:24 2024 +0100
Déplacement shift descriptor vers gfc_conv_array_parameter
Suppression variables inutilisées
Diff:
---
gcc/fortran/trans-array.cc | 49 ++
gcc/fortran/trans-array.h | 2 +-
gcc/fortran/trans-expr.cc | 20 +--
3 files changed, 43 insertions(+), 28 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 0370d10d9ebd..2fdd15962e49 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1151,6 +1151,43 @@ gfc_conv_shift_descriptor_lbound (stmtblock_t* block,
tree desc,
}
+static void
+conv_shift_descriptor (stmtblock_t* block, tree desc, int rank)
+{
+ /* Apply a shift of the lbound when supplied. */
+ for (int dim = 0; dim < rank; ++dim)
+gfc_conv_shift_descriptor_lbound (block, desc, dim,
+ gfc_index_one_node);
+}
+
+
+static bool
+keep_descriptor_lower_bound (gfc_expr *e)
+{
+ gfc_ref *ref;
+
+ /* Detect any array references with vector subscripts. */
+ for (ref = e->ref; ref; ref = ref->next)
+if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT
+ && ref->u.ar.type != AR_FULL)
+ {
+ int dim;
+ for (dim = 0; dim < ref->u.ar.dimen; dim++)
+ if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
+ break;
+ if (dim < ref->u.ar.dimen)
+ break;
+ }
+
+ /* Array references with vector subscripts and non-variable
+ expressions need be converted to a one-based descriptor. */
+ if (ref || e->expr_type != EXPR_VARIABLE)
+return false;
+
+ return true;
+}
+
+
/* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
void
@@ -9454,7 +9491,7 @@ is_pointer (gfc_expr *e)
void
gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77,
const gfc_symbol *fsym, const char *proc_name,
- tree *size, tree *lbshift, tree *packed)
+ tree *size, bool maybe_shift, tree *packed)
{
tree ptr;
tree desc;
@@ -9690,13 +9727,9 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr,
bool g77,
stmtblock_t block;
gfc_init_block (&block);
- if (lbshift && *lbshift)
- {
- /* Apply a shift of the lbound when supplied. */
- for (int dim = 0; dim < expr->rank; ++dim)
- gfc_conv_shift_descriptor_lbound (&block, se->expr, dim,
- *lbshift);
- }
+ if (maybe_shift && !keep_descriptor_lower_bound (expr))
+ conv_shift_descriptor (&block, se->expr, expr->rank);
+
tmp = gfc_class_data_get (ctree);
if (expr->rank > 1 && CLASS_DATA (fsym)->as->rank != expr->rank
&& CLASS_DATA (fsym)->as->type == AS_EXPLICIT && !no_pack)
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 78646275b4ec..17e3d08fdba0 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -158,7 +158,7 @@ tree gfc_get_array_span (tree, gfc_expr *);
void gfc_conv_expr_descriptor (gfc_se *, gfc_expr *);
/* Convert an array for passing as an actual function parameter. */
void gfc_conv_array_parameter (gfc_se *, gfc_expr *, bool, const gfc_symbol *,
- const char *, tree *, tree * = nullptr,
+ const char *, tree *, bool = false,
tree * = nullptr);
/* These work with both descriptors and descriptorless arrays. */
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 6978f83cdc8c..e8b229d853e3 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -991,8 +991,6 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
gfc_symbol *fsym,
stmtblock_t block;
gfc_init_block (&block);
gfc_ref *ref;
- int dim;
- tree lbshift = NULL_TREE;
/* Array refs with sections indicate, that a for a formal argument
expecting contiguous repacking needs to be done. */
@@ -1005,25 +1003,9 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
gfc_symbol *fsym,
&& (ref || e->rank != fsym->ts.u.derived->components->as->rank))
fsym->attr.contiguous = 1;
- /* Detect any array references with vector subscripts. */
- for (ref = e->ref; ref; ref = ref->next)
- if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT
- && ref->u.ar.type != AR_FULL)
- {
- for (dim = 0; dim < ref->u.ar.dimen; dim++)
- if (ref->u.ar.dimen_type[dim] == DIMEN_VECTOR)
- break;
- if (dim < ref->u.ar.dimen)
- break;
- }
-
[gcc] Deleted branch 'mikael/heads/refactor_descriptor_v01' in namespace 'refs/users'
The branch 'mikael/heads/refactor_descriptor_v01' in namespace 'refs/users' was deleted. It previously pointed to: e8d82306d889... Correction compil' Diff: !!! WARNING: THE FOLLOWING COMMITS ARE NO LONGER ACCESSIBLE (LOST): --- e8d8230... Correction compil' e4b734b... Factorisation set_descriptor_dimension 035bdb7... Factorisation gfc_conv_shift_descriptor. ff1a370... Correction régression allocated_4.f90 bec9cb8... Correction compil' 04da924... Factorisation gfc_conv_shift_descriptor 96c395b... Renseignement token par gfc_set_descriptor_from_scalar. cd99fad... Séparation motifs dump assumed_rank_12.f90 ac8ccbd... Annulation modif dump assumed_rank_12.f90 34baff5... Sauvegarde factorisation set_descriptor_from_scalar 47b6338... Déplacement gfc_set_gfc_from_cfi d292794... Déplacement gfc_copy_sequence_descriptor da0f060... Déplacement méthode set_descriptor_from_scalar 0aef327... Suppression code redondant 0838449... Update dump match count 01b40a5... Factorisation set_descriptor_from_scalar dans gfc_conv_scal c3d8cf0... Factorisation set_descriptor_from_scalar conv_derived_to_cl 60fb6b7... Factorisation set_descriptor_from_scalar dans conv_class_to 1392f13... Factorisation initialisation depuis cfi 84be5a4... utilisation booléen allocatable 57a9d25... Factorisation initialisation gfc depuis cfi 7d9a5b7... Refactoring gfc_conv_descriptor_sm_get. 55a2a10... Introduction gfc_conv_descriptor_extent_get c2ce739... Factorisation shift descriptor 41e3834... Factorisation initialisation subarray_descriptor c3a50c1... Factorisation set descriptor with shape b5834ef... Factorisation set_contiguous_array ccb2dcc... Factorisation set_contiguous_array bd3573d... Essai suppression unlimited_polymorphic a6d12d1... Refactor conv_shift_descriptor 7818e31... Factorisation shift descriptor 7421792... Factorisation shift descriptor d607595... Factorisation gfc_conv_expr_descriptor 82413c9... Factorisation copie gfc_conv_expr_descriptor ed6fee2... Extraction fonction fcncall_realloc_result 7ed0026... Factorisation gfc_conv_remap_descriptor 6d1a550... Introduction gfc_copy_sequence_descriptor b68e4d2... Utilisation de la méthode de nullification pour nullifier ecdc8da... Appel méthode shift descriptor dans gfc_trans_pointer_assi 063c001... Déplacement shift descriptor vers gfc_conv_array_parameter db8ddde... Utilisation gfc_clear_descriptor dans gfc_conv_derived_to_c e3de444... Sauvegarde modifs 3c45ca6... Creation méthode initialisation descripteur
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation gfc_conv_expr_descriptor
https://gcc.gnu.org/g:d607595f1f4f4566776000aeedfd4d0bb3ce4b9b
commit d607595f1f4f4566776000aeedfd4d0bb3ce4b9b
Author: Mikael Morin
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)
+ {
+
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation shift descriptor
https://gcc.gnu.org/g:7818e31b1ca1ea4796040325332a850765ef9fdd
commit 7818e31b1ca1ea4796040325332a850765ef9fdd
Author: Mikael Morin
Date: Thu Jan 16 14:51:42 2025 +0100
Factorisation shift descriptor
Diff:
---
gcc/fortran/trans-expr.cc | 7 +--
1 file changed, 1 insertion(+), 6 deletions(-)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 77e8a55af457..b7d1e3df0613 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1219,7 +1219,6 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
tree ctree;
tree var;
tree tmp;
- int dim;
bool unlimited_poly;
unlimited_poly = class_ts.type == BT_CLASS
@@ -1287,11 +1286,7 @@ gfc_conv_intrinsic_to_class (gfc_se *parmse, gfc_expr *e,
/* Array references with vector subscripts and non-variable
expressions
need be converted to a one-based descriptor. */
if (e->expr_type != EXPR_VARIABLE)
- {
- for (dim = 0; dim < e->rank; ++dim)
- gfc_conv_shift_descriptor_lbound (&parmse->pre, parmse->expr,
- dim, gfc_index_one_node);
- }
+ gfc_conv_shift_descriptor (&parmse->pre, parmse->expr, e->rank);
if (class_ts.u.derived->components->as->rank != e->rank)
{
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Déplacement méthode set_descriptor_from_scalar
https://gcc.gnu.org/g:da0f06041ed11f41d66b165320f27973c71d8186
commit da0f06041ed11f41d66b165320f27973c71d8186
Author: Mikael Morin
Date: Thu Jan 30 21:07:15 2025 +0100
Déplacement méthode set_descriptor_from_scalar
Correction erreur compil'
Diff:
---
gcc/fortran/trans-array.cc | 63 +++
gcc/fortran/trans-array.h | 3 ++
gcc/fortran/trans-expr.cc | 83 +-
3 files changed, 75 insertions(+), 74 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 4d08a862c5be..a1fb41fc9354 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1772,6 +1772,69 @@ gfc_set_descriptor_with_shape (stmtblock_t *block, tree
desc,
gfc_conv_descriptor_offset_set (block, desc, offset);
}
+/* Convert a scalar to an array descriptor. To be used for assumed-rank
+ arrays. */
+
+tree
+gfc_get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
+{
+ enum gfc_array_kind akind;
+
+ if (attr.pointer)
+akind = GFC_ARRAY_POINTER_CONT;
+ else if (attr.allocatable)
+akind = GFC_ARRAY_ALLOCATABLE;
+ else
+akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
+
+ if (POINTER_TYPE_P (TREE_TYPE (scalar)))
+scalar = TREE_TYPE (scalar);
+ return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
+ akind, !(attr.pointer || attr.target));
+}
+
+
+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);
+}
+
/* Obtain offsets for trans-types.cc(gfc_get_array_descr_info). */
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 296a8052dd73..691231f66903 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -147,6 +147,9 @@ void gfc_clear_descriptor (stmtblock_t *block, gfc_symbol
*, gfc_expr *, tree);
void gfc_set_scalar_descriptor (stmtblock_t *block, tree, gfc_symbol *,
gfc_expr *, tree);
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);
/* Get a single array element. */
void gfc_conv_array_ref (gfc_se *, gfc_array_ref *, gfc_expr *, locus *);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 18d54d2a1f93..2ece9d369d80 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -83,34 +83,12 @@ gfc_get_character_len_in_bytes (tree type)
}
-/* Convert a scalar to an array descriptor. To be used for assumed-rank
- arrays. */
-
-static tree
-get_scalar_to_descriptor_type (tree scalar, symbol_attribute attr)
-{
- enum gfc_array_kind akind;
-
- if (attr.pointer)
-akind = GFC_ARRAY_POINTER_CONT;
- else if (attr.allocatable)
-akind = GFC_ARRAY_ALLOCATABLE;
- else
-akind = GFC_ARRAY_ASSUMED_SHAPE_CONT;
-
- if (POINTER_TYPE_P (TREE_TYPE (scalar)))
-scalar = TREE_TYPE (scalar);
- return gfc_get_array_type_bounds (TREE_TYPE (scalar), 0, 0, NULL, NULL, 1,
- akind, !(attr.pointer || attr.target));
-}
-
-
tree
gfc_conv_scalar_null_to_descriptor (gfc_se *se, gfc_symbol *sym, gfc_expr
*expr, tree scalar)
{
symbol_attribute attr = sym->attr;
- tree type = get_scalar_to_descriptor_type (scalar, attr);
+ tree type = gfc_get_scalar_to_descriptor_type (scalar, attr);
tree desc = gfc_create_var (type, "desc");
DECL_ARTIFICIAL (desc) = 1;
@@ -172,55 +150,12 @@ gfc_conv_null_array_descriptor (gfc_se *se, gfc_symbol
*sym, gfc_expr *expr)
}
-void
-set_descriptor_from_scalar (stmtblock_t *block, tree desc, tree scalar,
-
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Factorisation set_descriptor_dimension
https://gcc.gnu.org/g:4ffb2a2326851d34a6d5de6fd08d1c024822e31f
commit 4ffb2a2326851d34a6d5de6fd08d1c024822e31f
Author: Mikael Morin
Date: Fri Feb 7 12:07:36 2025 +0100
Factorisation set_descriptor_dimension
Correction compil'
Diff:
---
gcc/fortran/trans-array.cc | 82 +-
1 file changed, 44 insertions(+), 38 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 09947b6fa602..545a88c13290 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1472,6 +1472,41 @@ gfc_build_null_descriptor (tree type)
}
+static tree
+set_descriptor_dimension (stmtblock_t *block, tree desc, int dim,
+ tree lbound, tree ubound, tree stride, tree *offset)
+{
+ /* Set bounds in descriptor. */
+ lbound = fold_convert (gfc_array_index_type, lbound);
+ lbound = gfc_evaluate_now (lbound, block);
+ gfc_conv_descriptor_lbound_set (block, desc,
+ gfc_rank_cst[dim], lbound);
+
+ ubound = fold_convert (gfc_array_index_type, ubound);
+ ubound = gfc_evaluate_now (ubound, block);
+ gfc_conv_descriptor_ubound_set (block, desc,
+ gfc_rank_cst[dim], ubound);
+
+ /* Set stride. */
+ stride = fold_convert (gfc_array_index_type, stride);
+ stride = gfc_evaluate_now (stride, block);
+ gfc_conv_descriptor_stride_set (block, desc,
+ gfc_rank_cst[dim], stride);
+
+ /* Update offset. */
+ tree tmp = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, lbound, stride);
+ *offset = fold_build2_loc (input_location, MINUS_EXPR,
+ gfc_array_index_type, *offset, tmp);
+
+ /* Return stride for next dimension. */
+ tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+ stride = fold_build2_loc (input_location, MULT_EXPR,
+ gfc_array_index_type, stride, tmp);
+ return stride;
+}
+
+
/* Modify a descriptor such that the lbound of a given dimension is the value
specified. This also updates ubound and offset accordingly. */
@@ -1821,9 +1856,9 @@ gfc_conv_remap_descriptor (stmtblock_t *block, tree dest,
tree src,
/* Copy offset but adjust it such that it would correspond
to a lbound of zero. */
+ tree offset;
if (src_rank == -1)
-gfc_conv_descriptor_offset_set (block, dest,
- gfc_index_zero_node);
+offset = gfc_index_zero_node;
else
{
tree offs = gfc_conv_descriptor_offset_get (src);
@@ -1839,7 +1874,7 @@ gfc_conv_remap_descriptor (stmtblock_t *block, tree dest,
tree src,
offs = fold_build2_loc (input_location, PLUS_EXPR,
gfc_array_index_type, offs, tmp);
}
- gfc_conv_descriptor_offset_set (block, dest, offs);
+ offset = offs;
}
/* Set the bounds as declared for the LHS and calculate strides as
well as another offset update accordingly. */
@@ -1855,46 +1890,17 @@ gfc_conv_remap_descriptor (stmtblock_t *block, tree
dest, tree src,
/* Convert declared bounds. */
gfc_init_se (&lower_se, NULL);
gfc_init_se (&upper_se, NULL);
- gfc_conv_expr (&lower_se, as.lower[dim]);
- gfc_conv_expr (&upper_se, as.upper[dim]);
+ gfc_conv_expr_val (&lower_se, as.lower[dim]);
+ gfc_conv_expr_val (&upper_se, as.upper[dim]);
gfc_add_block_to_block (block, &lower_se.pre);
gfc_add_block_to_block (block, &upper_se.pre);
- tree lbound = fold_convert (gfc_array_index_type, lower_se.expr);
- tree ubound = fold_convert (gfc_array_index_type, upper_se.expr);
-
- lbound = gfc_evaluate_now (lbound, block);
- ubound = gfc_evaluate_now (ubound, block);
-
- gfc_add_block_to_block (block, &lower_se.post);
- gfc_add_block_to_block (block, &upper_se.post);
-
- /* Set bounds in descriptor. */
- gfc_conv_descriptor_lbound_set (block, dest,
- gfc_rank_cst[dim], lbound);
- gfc_conv_descriptor_ubound_set (block, dest,
- gfc_rank_cst[dim], ubound);
-
- /* Set stride. */
- stride = gfc_evaluate_now (stride, block);
- gfc_conv_descriptor_stride_set (block, dest,
- gfc_rank_cst[dim], stride);
-
- /* Update offset. */
- tree offs = gfc_conv_descriptor_offset_get (dest);
- tmp = fold_build2_loc (input_location, MULT_EXPR,
-gfc_array_index_type, lbound, stride);
- offs = fold_build2_loc (input_location, MINUS_EXPR,
- gfc_array_index_type, offs, tmp);
- offs = gfc_evaluate_now (offs, block);
- gfc_conv_descriptor_offset_set (block, dest, offs);
-
- /* Update stride. */
- tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL);
- stride = fold_build2_loc (input_location, MULT_EX
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Annulation modif dump assumed_rank_12.f90
https://gcc.gnu.org/g:ac8ccbd19b684c86649d332a17e71a8d40ae6bbb
commit ac8ccbd19b684c86649d332a17e71a8d40ae6bbb
Author: Mikael Morin
Date: Wed Feb 5 11:45:00 2025 +0100
Annulation modif dump assumed_rank_12.f90
Diff:
---
gcc/fortran/trans-array.cc | 126 -
1 file changed, 124 insertions(+), 2 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 90eafe7ffe18..531281049646 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -1085,11 +1085,131 @@ field_count (tree type)
}
-bool
+#if 0
+static bool
complete_init_p (tree type, vec *init_values)
{
return (unsigned) field_count (type) == vec_safe_length (init_values);
}
+#endif
+
+
+static int
+cmp_wi (const void *x, const void *y)
+{
+ const offset_int *wix = (const offset_int *) x;
+ const offset_int *wiy = (const offset_int *) y;
+
+ return wi::cmpu (*wix, *wiy);
+}
+
+
+static offset_int
+get_offset_bits (tree field)
+{
+ offset_int field_offset = wi::to_offset (DECL_FIELD_OFFSET (field));
+ offset_int field_bit_offset = wi::to_offset (DECL_FIELD_BIT_OFFSET (field));
+ unsigned long offset_align = DECL_OFFSET_ALIGN (field);
+
+ return field_offset * offset_align + field_bit_offset;
+}
+
+
+static bool
+check_cleared_low_bits (const offset_int &val, int bitcount)
+{
+ if (bitcount == 0)
+return true;
+
+ offset_int mask = wi::mask (bitcount, false);
+ if ((val & mask) != 0)
+return false;
+
+ return true;
+}
+
+
+static bool
+right_shift_if_clear (const offset_int &val, int bitcount, offset_int *result)
+{
+ if (bitcount == 0)
+{
+ *result = val;
+ return true;
+}
+
+ if (!check_cleared_low_bits (val, bitcount))
+return false;
+
+ *result = val >> bitcount;
+ return true;
+}
+
+
+static bool
+contiguous_init_p (tree type, tree value)
+{
+ gcc_assert (TREE_CODE (value) == CONSTRUCTOR);
+ auto_vec field_offsets;
+ int count = field_count (type);
+ field_offsets.reserve (count);
+
+ tree field = TYPE_FIELDS (type);
+ offset_int expected_offset = 0;
+ while (field != NULL_TREE)
+{
+ offset_int field_offset_bits = get_offset_bits (field);
+ offset_int field_offset;
+ if (!right_shift_if_clear (field_offset_bits, 3, &field_offset))
+ return false;
+
+ offset_int type_size = wi::to_offset (TYPE_SIZE_UNIT (TREE_TYPE
(field)));
+ int align = wi::ctz (type_size);
+ if (!check_cleared_low_bits (field_offset, align))
+ return false;
+
+ if (field_offset != expected_offset)
+ return false;
+
+ expected_offset += type_size;
+ field_offsets.quick_push (field_offset);
+
+ field = DECL_CHAIN (field);
+}
+
+ auto_vec value_offsets;
+ value_offsets.reserve (count);
+
+ unsigned i;
+ tree field_init;
+ FOR_EACH_CONSTRUCTOR_ELT (CONSTRUCTOR_ELTS (value), i, field, field_init)
+{
+ if (TREE_TYPE (field) != TREE_TYPE (field_init))
+ return false;
+
+ offset_int field_offset_bits = get_offset_bits (field);
+ offset_int field_offset;
+ if (!right_shift_if_clear (field_offset_bits, 3, &field_offset))
+ return false;
+
+ value_offsets.quick_push (field_offset);
+}
+
+ value_offsets.qsort (cmp_wi);
+
+ unsigned idx = 0;
+ offset_int field_off, val_off;
+ while (field_offsets.iterate (idx, &field_off)
+&& value_offsets.iterate (idx, &val_off))
+{
+ if (val_off != field_off)
+ return false;
+
+ idx++;
+}
+
+ return true;
+}
static bool
@@ -1161,7 +1281,9 @@ init_struct (stmtblock_t *block, tree data_ref, init_kind
kind,
if (TREE_STATIC (data_ref)
|| !modifiable_p (data_ref))
DECL_INITIAL (data_ref) = value;
- else if (TREE_CODE (value) == CONSTRUCTOR)
+ else if (TREE_CODE (value) == CONSTRUCTOR
+ && !(TREE_CONSTANT (value)
+ && contiguous_init_p (type, value)))
{
unsigned i;
tree field, field_init;
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Essai suppression unlimited_polymorphic
https://gcc.gnu.org/g:bd3573d2425487de1c1d165e86d63ff83037c584
commit bd3573d2425487de1c1d165e86d63ff83037c584
Author: Mikael Morin
Date: Thu Jan 16 20:45:34 2025 +0100
Essai suppression unlimited_polymorphic
Diff:
---
gcc/fortran/trans-array.cc | 13 -
gcc/fortran/trans.h| 3 ---
2 files changed, 4 insertions(+), 12 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index bf11689cf3dd..4f066680dff0 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -9019,7 +9019,7 @@ 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)
+ bool data_needed, bool subref)
{
int ndim = info->ref ? info->ref->u.ar.dimen : rank;
@@ -9044,9 +9044,7 @@ set_descriptor (stmtblock_t *block, tree dest, tree src,
gfc_expr *src_expr,
/* 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)
+ if (src_expr->ts.type == BT_ASSUMED)
{
tree tmp2 = src;
if (DECL_LANG_SPECIFIC (tmp2) && GFC_DECL_SAVED_DESCRIPTOR (tmp2))
@@ -9056,7 +9054,7 @@ set_descriptor (stmtblock_t *block, tree dest, tree src,
gfc_expr *src_expr,
dtype = gfc_conv_descriptor_dtype (tmp2);
}
else
-dtype = gfc_get_dtype (TREE_TYPE (dest));
+dtype = gfc_get_dtype (TREE_TYPE (src), &rank);
gfc_add_modify (block, tmp, dtype);
/* The 1st element in the section. */
@@ -9254,9 +9252,6 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
expr = expr->value.function.actual->expr;
}
- if (!se->direct_byref)
-se->unlimited_polymorphic = UNLIMITED_POLY (expr);
-
/* Special case things we know we can pass easily. */
switch (expr->expr_type)
{
@@ -9660,7 +9655,7 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
}
set_descriptor (&loop.pre, parm, desc, expr, loop.dimen, codim,
- ss, info, loop.from, loop.to, se->unlimited_polymorphic,
+ ss, info, loop.from, loop.to,
!se->data_not_needed, subref_array_target);
desc = parm;
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 098fb07c1483..197dea0a18a6 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -61,9 +61,6 @@ typedef struct gfc_se
the reference to the class object here. */
tree class_container;
- /* Whether expr is a reference to an unlimited polymorphic object. */
- unsigned unlimited_polymorphic:1;
-
/* If set gfc_conv_variable will return an expression for the array
descriptor. When set, want_pointer should also be set.
If not set scalarizing variables will be substituted. */
[gcc r15-7408] LoongArch: Correct the mode for mask{eq,ne}z
https://gcc.gnu.org/g:bad9a7303a4b4ec8192e2ab5da49ab1a9cc86347
commit r15-7408-gbad9a7303a4b4ec8192e2ab5da49ab1a9cc86347
Author: Xi Ruoyao
Date: Sun Jan 19 21:26:59 2025 +0800
LoongArch: Correct the mode for mask{eq,ne}z
For mask{eq,ne}z, rk is always compared with 0 in the full width, thus
the mode for rk should be X.
I found the issue reviewing a patch fixing a similar issue for RISC-V
XTheadCondMov [1], but interestingly I cannot find a test case really
blowing up on LoongArch. But as the issue is obvious enough let's fix
it anyway so it won't blow up in the future.
[1]: https://gcc.gnu.org/pipermail/gcc-patches/2025-January/674004.html
gcc/ChangeLog:
* config/loongarch/loongarch.md
(*sel_using_): Rename to ...
(*sel_using_): ... here.
(GPR2): Remove as nothing uses it now.
Diff:
---
gcc/config/loongarch/loongarch.md | 10 +++---
1 file changed, 3 insertions(+), 7 deletions(-)
diff --git a/gcc/config/loongarch/loongarch.md
b/gcc/config/loongarch/loongarch.md
index 701f31fbb17c..36d140a9e942 100644
--- a/gcc/config/loongarch/loongarch.md
+++ b/gcc/config/loongarch/loongarch.md
@@ -374,10 +374,6 @@
;; from the same template.
(define_mode_iterator GPR [SI (DI "TARGET_64BIT")])
-;; A copy of GPR that can be used when a pattern has two independent
-;; modes.
-(define_mode_iterator GPR2 [SI (DI "TARGET_64BIT")])
-
;; This mode iterator allows 16-bit and 32-bit GPR patterns and 32-bit 64-bit
;; FPR patterns to be generated from the same template.
(define_mode_iterator JOIN_MODE [HI
@@ -2507,11 +2503,11 @@
;; Conditional move instructions.
-(define_insn "*sel_using_"
+(define_insn "*sel_using_"
[(set (match_operand:GPR 0 "register_operand" "=r,r")
(if_then_else:GPR
-(equality_op:GPR2 (match_operand:GPR2 1 "register_operand" "r,r")
- (const_int 0))
+(equality_op:X (match_operand:X 1 "register_operand" "r,r")
+ (const_int 0))
(match_operand:GPR 2 "reg_or_0_operand" "r,J")
(match_operand:GPR 3 "reg_or_0_operand" "J,r")))]
"register_operand (operands[2], mode)
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Creation méthode initialisation descripteur
https://gcc.gnu.org/g:3c45ca6ee9cb09354b7ede90cf410c13adeec82c
commit 3c45ca6ee9cb09354b7ede90cf410c13adeec82c
Author: Mikael Morin
Date: Thu Dec 5 20:30:08 2024 +0100
Creation méthode initialisation descripteur
Utilisation méthode initialisation descripteur gfc_trans_deferred_array
Correction variable inutilisée
Correction segmentation fault
Correction regression allocatable attribute
Ajout conversion elem_len
conversion type longueur chaine
Initialisation descripteur champ par champ
Silence uninitialized warning.
Diff:
---
gcc/fortran/expr.cc| 25 +++-
gcc/fortran/gfortran.h | 1 +
gcc/fortran/primary.cc | 84 +++-
gcc/fortran/trans-array.cc | 286 +
gcc/fortran/trans-intrinsic.cc | 2 +-
5 files changed, 333 insertions(+), 65 deletions(-)
diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc
index 7f3f6c52fb54..e4829448f710 100644
--- a/gcc/fortran/expr.cc
+++ b/gcc/fortran/expr.cc
@@ -5411,27 +5411,38 @@ gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
gfc_ref *ref;
if (expr->rank == 0)
-return NULL;
+return nullptr;
/* Follow any component references. */
if (expr->expr_type == EXPR_VARIABLE
|| expr->expr_type == EXPR_CONSTANT)
{
- if (expr->symtree)
- as = expr->symtree->n.sym->as;
+ gfc_symbol *sym = expr->symtree ? expr->symtree->n.sym : nullptr;
+ if (sym
+ && sym->ts.type == BT_CLASS)
+ as = CLASS_DATA (sym)->as;
+ else if (sym)
+ as = sym->as;
else
- as = NULL;
+ as = nullptr;
for (ref = expr->ref; ref; ref = ref->next)
{
switch (ref->type)
{
case REF_COMPONENT:
- as = ref->u.c.component->as;
+ {
+ gfc_component *comp = ref->u.c.component;
+ if (comp->ts.type == BT_CLASS)
+ as = CLASS_DATA (comp)->as;
+ else
+ as = comp->as;
+ }
continue;
case REF_SUBSTRING:
case REF_INQUIRY:
+ as = nullptr;
continue;
case REF_ARRAY:
@@ -5441,7 +5452,7 @@ gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
case AR_ELEMENT:
case AR_SECTION:
case AR_UNKNOWN:
- as = NULL;
+ as = nullptr;
continue;
case AR_FULL:
@@ -5453,7 +5464,7 @@ gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
}
}
else
-as = NULL;
+as = nullptr;
return as;
}
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 7367db8853c6..b14857132ed7 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -4049,6 +4049,7 @@ const char *gfc_dt_lower_string (const char *);
const char *gfc_dt_upper_string (const char *);
/* primary.cc */
+symbol_attribute gfc_symbol_attr (gfc_symbol *);
symbol_attribute gfc_variable_attr (gfc_expr *, gfc_typespec *);
symbol_attribute gfc_expr_attr (gfc_expr *);
symbol_attribute gfc_caf_attr (gfc_expr *, bool i = false, bool *r = NULL);
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 8a38720422ec..c934841f4795 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2867,42 +2867,14 @@ check_substring:
}
-/* Given an expression that is a variable, figure out what the
- ultimate variable's type and attribute is, traversing the reference
- structures if necessary.
-
- This subroutine is trickier than it looks. We start at the base
- symbol and store the attribute. Component references load a
- completely new attribute.
-
- A couple of rules come into play. Subobjects of targets are always
- targets themselves. If we see a component that goes through a
- pointer, then the expression must also be a target, since the
- pointer is associated with something (if it isn't core will soon be
- dumped). If we see a full part or section of an array, the
- expression is also an array.
-
- We can have at most one full array reference. */
-
symbol_attribute
-gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts)
+gfc_symbol_attr (gfc_symbol *sym)
{
- int dimension, codimension, pointer, allocatable, target, optional;
+ int dimension, codimension, pointer, allocatable, target;
symbol_attribute attr;
- gfc_ref *ref;
- gfc_symbol *sym;
- gfc_component *comp;
- bool has_inquiry_part;
-
- if (expr->expr_type != EXPR_VARIABLE
- && expr->expr_type != EXPR_FUNCTION
- && !(expr->expr_type == EXPR_NULL && expr->ts.type != BT_UNKNOWN))
-gfc_internal_error ("gfc_variable_attr(): Expression isn't a variable");
- sym = expr->symtree->n.sym;
attr = sym->attr;
- optional = attr.optional;
if (sym->ts.type == BT_CLASS && sym->attr.class_ok && sym->ts.u.derived)
{
[gcc(refs/users/mikael/heads/refactor_descriptor_v01)] Sauvegarde modifs
https://gcc.gnu.org/g:e3de44455296f04e014dad8c9efaef858384cfac
commit e3de44455296f04e014dad8c9efaef858384cfac
Author: Mikael Morin
Date: Sat Dec 7 22:22:10 2024 +0100
Sauvegarde modifs
Annulation suppression else
Correction assertions
Initialisation vptr
Non initialisation elem_len pour les conteneurs de classe
Mise à jour class_allocatable_14
Diff:
---
gcc/fortran/trans-array.cc | 52 ++
gcc/fortran/trans-array.h | 2 +
gcc/fortran/trans-decl.cc | 58 +
gcc/testsuite/gfortran.dg/class_allocate_14.f90 | 2 +-
4 files changed, 66 insertions(+), 48 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 268de211cd66..d15576adde10 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -734,6 +734,58 @@ gfc_build_null_descriptor (tree type, gfc_typespec &ts,
}
+tree
+gfc_build_default_class_descriptor (tree type, gfc_typespec &ts)
+{
+ vec *v = nullptr;
+
+ tree fields = TYPE_FIELDS (type);
+
+#define CLASS_DATA_FIELD 0
+#define CLASS_VPTR_FIELD 1
+
+ tree data_field = gfc_advance_chain (fields, CLASS_DATA_FIELD);
+ tree data_type = TREE_TYPE (data_field);
+
+ gcc_assert (ts.type == BT_CLASS);
+ tree data_value;
+ if (ts.u.derived->components->attr.dimension
+ || (ts.u.derived->components->attr.codimension
+ && flag_coarray != GFC_FCOARRAY_LIB))
+{
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (data_type));
+ data_value = gfc_build_null_descriptor (data_type,
+ ts,
+
ts.u.derived->components->as->rank,
+ ts.u.derived->components->attr);
+}
+ else
+{
+ gcc_assert (POINTER_TYPE_P (data_type));
+ data_value = fold_convert (data_type, null_pointer_node);
+}
+ CONSTRUCTOR_APPEND_ELT (v, data_field, data_value);
+
+ tree vptr_field = gfc_advance_chain (fields, CLASS_VPTR_FIELD);
+
+ tree vptr_value;
+ if (ts.u.derived->attr.unlimited_polymorphic)
+vptr_value = fold_convert (TREE_TYPE (vptr_field), null_pointer_node);
+ else
+{
+ gfc_symbol *vsym = gfc_find_derived_vtab (ts.u.derived);
+ tree vsym_decl = gfc_get_symbol_decl (vsym);
+ vptr_value = gfc_build_addr_expr (nullptr, vsym_decl);
+}
+ CONSTRUCTOR_APPEND_ELT (v, vptr_field, vptr_value);
+
+#undef CLASS_DATA_FIELD
+#undef CLASS_VPTR_FIELD
+
+ return build_constructor (type, v);
+}
+
+
void
gfc_clear_descriptor (gfc_expr *var_ref, gfc_se &var)
{
diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h
index 1bb3294b0749..63a77d562a7b 100644
--- a/gcc/fortran/trans-array.h
+++ b/gcc/fortran/trans-array.h
@@ -140,6 +140,8 @@ void gfc_set_delta (gfc_loopinfo *);
void gfc_conv_resolve_dependencies (gfc_loopinfo *, gfc_ss *, gfc_ss *);
/* Build a null array descriptor constructor. */
tree gfc_build_null_descriptor (tree);
+tree gfc_build_default_class_descriptor (tree, gfc_typespec &);
+void gfc_clear_descriptor (stmtblock_t *block, gfc_symbol *sym, tree
descriptor);
/* Get a single array element. */
void gfc_conv_array_ref (gfc_se *, gfc_array_ref *, gfc_expr *, locus *);
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 4ae22a5584d0..dad15858fa6a 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -4780,16 +4780,14 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym,
gfc_wrapped_block * block)
else if (proc_sym == proc_sym->result && IS_CLASS_ARRAY (proc_sym))
{
/* Nullify explicit return class arrays on entry. */
- tree type;
tmp = get_proc_result (proc_sym);
- if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
- {
- gfc_start_block (&init);
- tmp = gfc_class_data_get (tmp);
- type = TREE_TYPE (gfc_conv_descriptor_data_get (tmp));
- gfc_conv_descriptor_data_set (&init, tmp, build_int_cst (type, 0));
- gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
- }
+ if (tmp && GFC_CLASS_TYPE_P (TREE_TYPE (tmp)))
+ {
+ gfc_start_block (&init);
+ tmp = gfc_class_data_get (tmp);
+ gfc_clear_descriptor (&init, proc_sym, tmp);
+ gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
+ }
}
@@ -4931,48 +4929,13 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym,
gfc_wrapped_block * block)
}
}
- if (sym->attr.pointer && sym->attr.dimension
- && sym->attr.save == SAVE_NONE
- && !sym->attr.use_assoc
- && !sym->attr.host_assoc
- && !sym->attr.dummy
- && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl)))
- {
- gfc_init_block (&tmpblock);
- gfc_conv_descriptor_span_set (&tmpblock, sym->backend_decl,
-
[gcc r15-7407] [ifcombine] avoid creating out-of-bounds BIT_FIELD_REFs [PR118514]
https://gcc.gnu.org/g:075ddb5226c40c4d86ab56b772822fb6494e
commit r15-7407-g075ddb5226c40c4d86ab56b772822fb6494e
Author: Alexandre Oliva
Date: Fri Feb 7 08:30:47 2025 -0300
[ifcombine] avoid creating out-of-bounds BIT_FIELD_REFs [PR118514]
If decode_field_reference finds a load that accesses past the inner
object's size, bail out.
Drop the too-strict assert.
for gcc/ChangeLog
PR tree-optimization/118514
PR tree-optimization/118706
* gimple-fold.cc (decode_field_reference): Refuse to consider
merging out-of-bounds BIT_FIELD_REFs.
(make_bit_field_load): Drop too-strict assert.
* tree-eh.cc (bit_field_ref_in_bounds_p): Rename to...
(access_in_bounds_of_type_p): ... this. Change interface,
export.
(tree_could_trap_p): Adjust.
* tree-eh.h (access_in_bounds_of_type_p): Declare.
for gcc/testsuite/ChangeLog
PR tree-optimization/118514
PR tree-optimization/118706
* gcc.dg/field-merge-25.c: New.
Diff:
---
gcc/gimple-fold.cc| 11 ++-
gcc/testsuite/gcc.dg/field-merge-25.c | 15 +++
gcc/tree-eh.cc| 25 +
gcc/tree-eh.h | 1 +
4 files changed, 31 insertions(+), 21 deletions(-)
diff --git a/gcc/gimple-fold.cc b/gcc/gimple-fold.cc
index 45485782cdf9..29191685a43c 100644
--- a/gcc/gimple-fold.cc
+++ b/gcc/gimple-fold.cc
@@ -7686,10 +7686,8 @@ decode_field_reference (tree *pexp, HOST_WIDE_INT
*pbitsize,
|| bs <= shiftrt
|| offset != 0
|| TREE_CODE (inner) == PLACEHOLDER_EXPR
- /* Reject out-of-bound accesses (PR79731). */
- || (! AGGREGATE_TYPE_P (TREE_TYPE (inner))
- && compare_tree_int (TYPE_SIZE (TREE_TYPE (inner)),
- bp + bs) < 0)
+ /* Reject out-of-bound accesses (PR79731, PR118514). */
+ || !access_in_bounds_of_type_p (TREE_TYPE (inner), bs, bp)
|| (INTEGRAL_TYPE_P (TREE_TYPE (inner))
&& !type_has_mode_precision_p (TREE_TYPE (inner
return NULL_TREE;
@@ -7859,11 +7857,6 @@ make_bit_field_load (location_t loc, tree inner, tree
orig_inner, tree type,
gimple *new_stmt = gsi_stmt (i);
if (gimple_has_mem_ops (new_stmt))
gimple_set_vuse (new_stmt, reaching_vuse);
- gcc_checking_assert (! (gimple_assign_load_p (point)
- && gimple_assign_load_p (new_stmt))
- || (tree_could_trap_p (gimple_assign_rhs1 (point))
- == tree_could_trap_p (gimple_assign_rhs1
-(new_stmt;
}
gimple_stmt_iterator gsi = gsi_for_stmt (point);
diff --git a/gcc/testsuite/gcc.dg/field-merge-25.c
b/gcc/testsuite/gcc.dg/field-merge-25.c
new file mode 100644
index ..e769b0ae7b84
--- /dev/null
+++ b/gcc/testsuite/gcc.dg/field-merge-25.c
@@ -0,0 +1,15 @@
+/* { dg-do compile } */
+/* { dg-options "-O1 -fno-tree-fre" } */
+
+/* PR tree-optimization/118706 */
+
+int a[1][1][3], b;
+int main() {
+ int c = -1;
+ while (b) {
+if (a[c][c][6])
+ break;
+if (a[0][0][0])
+ break;
+ }
+}
diff --git a/gcc/tree-eh.cc b/gcc/tree-eh.cc
index 7015189a2de8..a4d59954c059 100644
--- a/gcc/tree-eh.cc
+++ b/gcc/tree-eh.cc
@@ -2646,24 +2646,22 @@ range_in_array_bounds_p (tree ref)
return true;
}
-/* Return true iff EXPR, a BIT_FIELD_REF, accesses a bit range that is known to
- be in bounds for the referred operand type. */
+/* Return true iff a BIT_FIELD_REF <(TYPE)???, SIZE, OFFSET> would access a bit
+ range that is known to be in bounds for TYPE. */
-static bool
-bit_field_ref_in_bounds_p (tree expr)
+bool
+access_in_bounds_of_type_p (tree type, poly_uint64 size, poly_uint64 offset)
{
- tree size_tree;
- poly_uint64 size_max, min, wid, max;
+ tree type_size_tree;
+ poly_uint64 type_size_max, min = offset, wid = size, max;
- size_tree = TYPE_SIZE (TREE_TYPE (TREE_OPERAND (expr, 0)));
- if (!size_tree || !poly_int_tree_p (size_tree, &size_max))
+ type_size_tree = TYPE_SIZE (type);
+ if (!type_size_tree || !poly_int_tree_p (type_size_tree, &type_size_max))
return false;
- min = bit_field_offset (expr);
- wid = bit_field_size (expr);
max = min + wid;
if (maybe_lt (max, min)
- || maybe_lt (size_max, max))
+ || maybe_lt (type_size_max, max))
return false;
return true;
@@ -2712,7 +2710,10 @@ tree_could_trap_p (tree expr)
switch (code)
{
case BIT_FIELD_REF:
- if (DECL_P (TREE_OPERAND (expr, 0)) && !bit_field_ref_in_bounds_p (expr))
+ if (DECL_P (TREE_OPERAND (expr, 0))
+ && !access_in_bounds_of_type_p (TREE_TYPE (TREE_OPERAND (expr, 0)),
+ bit_field_size (expr),
+ bit_field
[gcc r15-7406] [gcn] Add gfx9-generic and generic-associated gfx*
https://gcc.gnu.org/g:b5a29a93ee29a882c9ed28cb0e6835f97d6f8182
commit r15-7406-gb5a29a93ee29a882c9ed28cb0e6835f97d6f8182
Author: Tobias Burnus
Date: Fri Feb 7 11:55:08 2025 +0100
[gcn] Add gfx9-generic and generic-associated gfx*
This patch adds gfx9-generic, completing the gfx*-generic support.
It also adds all gfx* devices that are part of any of the gfx*-generic,
i.e. gfx902, gfx904, gfx909, gfx1031, gfx1032, gfx1033, gfx1034,
gfx1035, gfx1101, gfx1102, gfx1150, gfx1151, gfx1152, and gfx1153.
gcc/ChangeLog:
* config/gcn/gcn-devices.def (GCN_DEVICE): Add gfx9-generic,
gfx902, gfx904, gfx909, gfx1031, gfx1032, gfx1033, gfx1034,
gfx1035, gfx1101, gfx1102, gfx1150, gfx1151, gfx1152, and gfx1153.
Add a currently unused column linking, a specific ISA to a generic
one (if it exists).
* config/gcn/gcn-tables.opt: Regenerate
* doc/invoke.texi (AMD GCN): Add the the new gfc... and the older
gfx{10-3,11}-generic to -march= as 'experimental'.
Diff:
---
gcc/config/gcn/gcn-devices.def | 202 ++---
gcc/config/gcn/gcn-tables.opt | 45 +
gcc/doc/invoke.texi| 53 +++
3 files changed, 289 insertions(+), 11 deletions(-)
diff --git a/gcc/config/gcn/gcn-devices.def b/gcc/config/gcn/gcn-devices.def
index a8b21a358b48..af1420382e2f 100644
--- a/gcc/config/gcn/gcn-devices.def
+++ b/gcc/config/gcn/gcn-devices.def
@@ -71,6 +71,10 @@
generated by the used llvm-mc assembler.
10 "Architecture Family Name" (string, external)
Used to #define '__GFX<...>__'.
+ 11 "GENERIC NAME" (text, external)
+ The name of the generic ISA this device is compatible with or "NONE",
+ where the generic name is the NAME (field 2) of the associated
+ generic device.
Fields marked "external", above, have values defined elsewhere (HSA, ROCM,
LLVM, ELF, etc.) and must have matching definitions here. Fields marked
@@ -86,7 +90,30 @@ GCN_DEVICE(gfx900, GFX900, 0x2c, ISA_GCN5,
/* CU mode */ HSACO_ATTR_UNSUPPORTED,
/* Max ISA VGPRs */ 256,
/* Generic code obj version */ 0, /* non-generic */
- /* Architecture Family */ GFX9
+ /* Architecture Family */ GFX9,
+ /* Generic Name */ GFX9_GENERIC
+ )
+
+GCN_DEVICE(gfx902, GFX902, 0x2d, ISA_GCN5,
+ /* XNACK default */ HSACO_ATTR_OFF,
+ /* SRAM_ECC default */ HSACO_ATTR_UNSUPPORTED,
+ /* WAVE64 mode */ HSACO_ATTR_UNSUPPORTED,
+ /* CU mode */ HSACO_ATTR_UNSUPPORTED,
+ /* Max ISA VGPRs */ 256,
+ /* Generic code obj version */ 0, /* non-generic */
+ /* Architecture Family */ GFX9,
+ /* Generic Name */ GFX9_GENERIC
+ )
+
+GCN_DEVICE(gfx904, GFX904, 0x2e, ISA_GCN5,
+ /* XNACK default */ HSACO_ATTR_OFF,
+ /* SRAM_ECC default */ HSACO_ATTR_UNSUPPORTED,
+ /* WAVE64 mode */ HSACO_ATTR_UNSUPPORTED,
+ /* CU mode */ HSACO_ATTR_UNSUPPORTED,
+ /* Max ISA VGPRs */ 256,
+ /* Generic code obj version */ 0, /* non-generic */
+ /* Architecture Family */ GFX9,
+ /* Generic Name */ GFX9_GENERIC
)
GCN_DEVICE(gfx906, GFX906, 0x2f, ISA_GCN5,
@@ -96,7 +123,8 @@ GCN_DEVICE(gfx906, GFX906, 0x2f, ISA_GCN5,
/* CU mode */ HSACO_ATTR_UNSUPPORTED,
/* Max ISA VGPRs */ 256,
/* Generic code obj version */ 0, /* non-generic */
- /* Architecture Family */ GFX9
+ /* Architecture Family */ GFX9,
+ /* Generic Name */ GFX9_GENERIC
)
GCN_DEVICE(gfx908, GFX908, 0x30, ISA_CDNA1,
@@ -106,7 +134,19 @@ GCN_DEVICE(gfx908, GFX908, 0x30, ISA_CDNA1,
/* CU mode */ HSACO_ATTR_UNSUPPORTED,
/* Max ISA VGPRs */ 256,
/* Generic code obj version */ 0, /* non-generic */
- /* Architecture Family */ GFX9
+ /* Architecture Family */ GFX9,
+ /* Generic Name */ NONE
+ )
+
+GCN_DEVICE(gfx909, GFX909, 0x31, ISA_GCN5,
+ /* XNACK default */ HSACO_ATTR_ANY,
+ /* SRAM_ECC default */ HSACO_ATTR_UNSUPPORTED,
+ /* WAVE64 mode */ HSACO_ATTR_UNSUPPORTED,
+ /* CU mode */ HSACO_ATTR_UNSUPPORTED,
+ /* Max ISA VGPRs */ 256,
+ /* Generic code obj version */ 0, /* non-generic */
+ /* Architecture Family */ GFX9,
+ /* Generic Name */ GFX9_GENERIC
)
GCN_DEVICE(gfx90a, GFX90A, 0x3f, ISA_CDNA2,
@@ -116,7 +156,8 @@ GCN_DEVICE(gfx90a, GFX90A, 0x3f, ISA_CDNA2,
/* CU mode */ HSACO_ATTR_UNSUPPORTED,
/* Max ISA VGPRs */ 512,
/* Generic code obj version */ 0, /* non-generic */
- /* Architecture Family */ GFX9
+ /* Architecture Family */ GFX9,
+ /* Generic Name */ NONE
)
GCN_DEVICE(gfx90c, GFX90C, 0x32, ISA_GCN5
[gcc r15-7409] [GCN] Handle generic ISA names in libgomp's plugin-gcn.c
https://gcc.gnu.org/g:8561e4e2903ae0b4aff1ed1dc9e9871c89df6b43
commit r15-7409-g8561e4e2903ae0b4aff1ed1dc9e9871c89df6b43
Author: Tobias Burnus
Date: Fri Feb 7 13:20:25 2025 +0100
[GCN] Handle generic ISA names in libgomp's plugin-gcn.c
libgomp/ChangeLog:
* plugin/plugin-gcn.c (ELFABIVERSION_AMDGPU_HSA_V6,
EF_AMDGPU_GENERIC_VERSION_V, EF_AMDGPU_GENERIC_VERSION_OFFSET,
GET_GENERIC_VERSION): New #define.
(elf_gcn_isa_is_generic): New.
(isa_matches_agent): Accept all generic code objects on the first
go; extend the diagnostic and handle runtime-failed case.
(create_and_finalize_hsa_program): Call it also after loading
the code failed, pass the status.
Diff:
---
libgomp/plugin/plugin-gcn.c | 118 ++--
1 file changed, 92 insertions(+), 26 deletions(-)
diff --git a/libgomp/plugin/plugin-gcn.c b/libgomp/plugin/plugin-gcn.c
index 8015a6f80f3d..5c65778191a6 100644
--- a/libgomp/plugin/plugin-gcn.c
+++ b/libgomp/plugin/plugin-gcn.c
@@ -66,6 +66,14 @@
#define R_AMDGPU_RELATIVE6413 /* B + A */
#endif
+#define ELFABIVERSION_AMDGPU_HSA_V64
+
+#define EF_AMDGPU_GENERIC_VERSION_V0xff00 /* Mask. */
+#define EF_AMDGPU_GENERIC_VERSION_OFFSET 24
+
+#define GET_GENERIC_VERSION(VAR) ((VAR & EF_AMDGPU_GENERIC_VERSION_V) \
+ >> EF_AMDGPU_GENERIC_VERSION_OFFSET)
+
/* GCN specific definitions for asynchronous queues. */
#define ASYNC_QUEUE_SIZE 64
@@ -242,7 +250,7 @@ struct kernel_dispatch
};
/* Structure of the kernargs segment, supporting console output.
-
+
This needs to match the definitions in Newlib, and the expectations
in libgomp target code. */
@@ -1668,6 +1676,13 @@ elf_gcn_isa_field (Elf64_Ehdr *image)
return image->e_flags & EF_AMDGPU_MACH_MASK;
}
+static int
+elf_gcn_isa_is_generic (Elf64_Ehdr *image)
+{
+ return (image->e_ident[8] == ELFABIVERSION_AMDGPU_HSA_V6
+ && GET_GENERIC_VERSION (image->e_flags));
+}
+
/* Returns the name that the HSA runtime uses for the ISA or NULL if we do not
support the ISA. */
@@ -2399,38 +2414,88 @@ init_basic_kernel_info (struct kernel_info *kernel,
return true;
}
-/* Check that the GCN ISA of the given image matches the ISA of the agent. */
+/* If status is SUCCESS, assume that the code runs if either the ISA of agent
+ and code is the same - or it is generic code.
+ Otherwise, execution failed with the provided status code; try to give
+ some useful diagnostic. */
static bool
-isa_matches_agent (struct agent_info *agent, Elf64_Ehdr *image)
+isa_matches_agent (struct agent_info *agent, Elf64_Ehdr *image,
+ hsa_status_t status)
{
+ /* Generic image - assume that it works and only return to here
+ when it fails, i.e. fatal == true. */
+ if (status == HSA_STATUS_SUCCESS && elf_gcn_isa_is_generic (image))
+return true;
+
int isa_field = elf_gcn_isa_field (image);
- const char* isa_s = isa_name (isa_field);
- if (!isa_s)
+ if (status == HSA_STATUS_SUCCESS && isa_field == agent->device_isa)
+return true;
+
+ /* If we get here, either the binary is non-generic and has a mismatch of
+ the ISA - or is generic but not handled by the ROCm (e.g. because ROCm
+ is too old). */
+
+ char msg[340];
+ char agent_isa_xs[8];
+ char device_isa_xs[8];
+ const char *agent_isa_s = isa_name (agent->device_isa);
+ const char *device_isa_s = isa_name (isa_field);
+ if (agent_isa_s == NULL)
{
- hsa_error ("Unsupported ISA in GCN code object.", HSA_STATUS_ERROR);
- return false;
+ snprintf (agent_isa_xs, sizeof agent_isa_xs,
+ "0x%X", agent->device_isa);
+ agent_isa_s = agent_isa_xs;
}
-
- if (isa_field != agent->device_isa)
+ if (device_isa_s == NULL)
{
- char msg[204];
- const char *agent_isa_s = isa_name (agent->device_isa);
- assert (agent_isa_s);
-
- snprintf (msg, sizeof msg,
- "GCN code object ISA '%s' does not match GPU ISA '%s' "
- "(device %d).\n"
- "Try to recompile with '-foffload-options=-march=%s',\n"
- "or use ROCR_VISIBLE_DEVICES to disable incompatible "
- "devices.\n",
- isa_s, agent_isa_s, agent->device_id, agent_isa_s);
-
- hsa_error (msg, HSA_STATUS_ERROR);
- return false;
+ snprintf (device_isa_xs, sizeof device_isa_xs, "0x%X", isa_field);
+ device_isa_s = device_isa_xs;
}
- return true;
+ /* Some error which should be unrelated to the ISA. */
+ if (status != HSA_STATUS_SUCCESS
+ && status != HSA_STATUS_ERROR_INVALID_CODE_OBJECT
+ && status != HSA_STATUS_ERROR_INVALID_ISA_NAME
+ && status != HSA_STATUS_ERROR_INCOMPATIBLE_ARGUMENTS)
+snprintf (msg, sizeof msg,
+ "Could not load GCN code object with ISA %s on GPU with "
+
[gcc r15-7411] tree-optimization/115538 - possible wrong-code with SLP conversion
https://gcc.gnu.org/g:4931a637479aba35e35c50a86f58ecd6262bc487
commit r15-7411-g4931a637479aba35e35c50a86f58ecd6262bc487
Author: Richard Biener
Date: Fri Feb 7 08:46:31 2025 +0100
tree-optimization/115538 - possible wrong-code with SLP conversion
The following fixes a latent issue where we use ranges to verify
correctness of a vector conversion optimization. We rely on ranges
from 'op0' which for SLP is extracted from the representative stmt
which does not necessarily correspond to any actual scalar operation.
We also do not verify the range of all scalar lanes in the SLP
operand match. The following rectifies this, restricting the support
to single-lane SLP nodes at this point - on branches we'd simply
not perform this optimization with SLP.
PR tree-optimization/115538
* tree-vectorizer.h (vect_get_slp_scalar_def): Declare.
* tree-vect-slp.cc (vect_get_slp_scalar_def): New helper.
* tree-vect-generic.cc (expand_vector_conversion): Adjust.
* tree-vect-stmts.cc (vectorizable_conversion): For SLP
correctly look at ranges of the scalar defs of the SLP operand.
(supportable_indirect_convert_operation): Likewise.
Diff:
---
gcc/tree-vect-generic.cc | 6 ++
gcc/tree-vect-slp.cc | 19 +++
gcc/tree-vect-stmts.cc | 38 --
gcc/tree-vectorizer.h| 4 +++-
4 files changed, 52 insertions(+), 15 deletions(-)
diff --git a/gcc/tree-vect-generic.cc b/gcc/tree-vect-generic.cc
index c2f7a29d539b..173ebd9a7ba6 100644
--- a/gcc/tree-vect-generic.cc
+++ b/gcc/tree-vect-generic.cc
@@ -1755,10 +1755,8 @@ expand_vector_conversion (gimple_stmt_iterator *gsi)
modifier = WIDEN;
auto_vec > converts;
- if (supportable_indirect_convert_operation (code,
- ret_type, arg_type,
- converts,
- arg))
+ if (supportable_indirect_convert_operation (code, ret_type, arg_type,
+ converts))
{
new_rhs = arg;
for (unsigned int i = 0; i < converts.length () - 1; i++)
diff --git a/gcc/tree-vect-slp.cc b/gcc/tree-vect-slp.cc
index ac1733004b68..8ed746ea5a9e 100644
--- a/gcc/tree-vect-slp.cc
+++ b/gcc/tree-vect-slp.cc
@@ -10199,6 +10199,25 @@ vect_create_constant_vectors (vec_info *vinfo,
slp_tree op_node)
SLP_TREE_VEC_DEFS (op_node).quick_push (vop);
}
+/* Get the scalar definition of the Nth lane from SLP_NODE or NULL_TREE
+ if there is no definition for it in the scalar IL or it is not known. */
+
+tree
+vect_get_slp_scalar_def (slp_tree slp_node, unsigned n)
+{
+ if (SLP_TREE_DEF_TYPE (slp_node) == vect_internal_def)
+{
+ if (!SLP_TREE_SCALAR_STMTS (slp_node).exists ())
+ return NULL_TREE;
+ stmt_vec_info def = SLP_TREE_SCALAR_STMTS (slp_node)[n];
+ if (!def)
+ return NULL_TREE;
+ return gimple_get_lhs (STMT_VINFO_STMT (def));
+}
+ else
+return SLP_TREE_SCALAR_OPS (slp_node)[n];
+}
+
/* Get the Ith vectorized definition from SLP_NODE. */
tree
diff --git a/gcc/tree-vect-stmts.cc b/gcc/tree-vect-stmts.cc
index 1b639ae3b174..6bbb16beff2c 100644
--- a/gcc/tree-vect-stmts.cc
+++ b/gcc/tree-vect-stmts.cc
@@ -5610,10 +5610,8 @@ vectorizable_conversion (vec_info *vinfo,
return false;
gcc_assert (code.is_tree_code ());
if (supportable_indirect_convert_operation (code,
- vectype_out,
- vectype_in,
- converts,
- op0))
+ vectype_out, vectype_in,
+ converts, op0, slp_op0))
{
gcc_assert (converts.length () <= 2);
if (converts.length () == 1)
@@ -5750,7 +5748,16 @@ vectorizable_conversion (vec_info *vinfo,
else if (code == FLOAT_EXPR)
{
wide_int op_min_value, op_max_value;
- if (!vect_get_range_info (op0, &op_min_value, &op_max_value))
+ if (slp_node)
+ {
+ tree def;
+ /* ??? Merge ranges in case of more than one lane. */
+ if (SLP_TREE_LANES (slp_op0) != 1
+ || !(def = vect_get_slp_scalar_def (slp_op0, 0))
+ || !vect_get_range_info (def, &op_min_value, &op_max_value))
+ goto unsupported;
+ }
+ else if (!vect_get_range_info (op0, &op_min_value, &op_max_value))
goto unsupported;
cvt_type
@@ -15197,7 +15204,7 @@ supportable_indirect_convert_operation (code_helper
code,
tree vectype_out,
tree vectype_in,
[gcc r15-7412] Fortran: Fix default init of finalizable derived argus [PR116829]
https://gcc.gnu.org/g:251aa524a314faa749b7dd1b7da048e6e6476015
commit r15-7412-g251aa524a314faa749b7dd1b7da048e6e6476015
Author: Paul Thomas
Date: Fri Feb 7 12:46:44 2025 +
Fortran: Fix default init of finalizable derived argus [PR116829]
2025-02-07 Tomáš Trnka
gcc/fortran
PR fortran/116829
* trans-decl.cc (init_intent_out_dt): Always call
gfc_init_default_dt() for BT_DERIVED to apply s->value if the
symbol isn't allocatable. Also simplify the logic a bit.
gcc/testsuite/
PR fortran/116829
* gfortran.dg/derived_init_7.f90: New test.
Diff:
---
gcc/fortran/trans-decl.cc| 21 +++---
gcc/testsuite/gfortran.dg/derived_init_7.f90 | 58
2 files changed, 64 insertions(+), 15 deletions(-)
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 017f184f1794..83f8130afd87 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -4551,7 +4551,6 @@ init_intent_out_dt (gfc_symbol * proc_sym,
gfc_wrapped_block * block)
tree tmp;
tree present;
gfc_symbol *s;
- bool dealloc_with_value = false;
gfc_init_block (&init);
for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)
@@ -4582,12 +4581,9 @@ init_intent_out_dt (gfc_symbol * proc_sym,
gfc_wrapped_block * block)
by the caller. */
if (tmp == NULL_TREE && !s->attr.allocatable
&& s->ts.u.derived->attr.alloc_comp)
- {
- tmp = gfc_deallocate_alloc_comp (s->ts.u.derived,
-s->backend_decl,
-s->as ? s->as->rank : 0);
- dealloc_with_value = s->value;
- }
+ tmp = gfc_deallocate_alloc_comp (s->ts.u.derived,
+ s->backend_decl,
+ s->as ? s->as->rank : 0);
if (tmp != NULL_TREE && (s->attr.optional
|| s->ns->proc_name->attr.entry_master))
@@ -4597,14 +4593,9 @@ init_intent_out_dt (gfc_symbol * proc_sym,
gfc_wrapped_block * block)
present, tmp, build_empty_stmt (input_location));
}
- if (tmp != NULL_TREE && !dealloc_with_value)
- gfc_add_expr_to_block (&init, tmp);
- else if (s->value && !s->attr.allocatable)
- {
- gfc_add_expr_to_block (&init, tmp);
- gfc_init_default_dt (s, &init, false);
- dealloc_with_value = false;
- }
+ gfc_add_expr_to_block (&init, tmp);
+ if (s->value && !s->attr.allocatable)
+ gfc_init_default_dt (s, &init, false);
}
else if (f->sym && f->sym->attr.intent == INTENT_OUT
&& f->sym->ts.type == BT_CLASS
diff --git a/gcc/testsuite/gfortran.dg/derived_init_7.f90
b/gcc/testsuite/gfortran.dg/derived_init_7.f90
new file mode 100644
index ..f145385b5e21
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/derived_init_7.f90
@@ -0,0 +1,58 @@
+! { dg-do run }
+! Check that finalizable intent(out) dummy arguments are first finalized
+! and then correctly default-initialized (PR116829)
+!
+! Contributed by Tomas Trnka
+!
+module FinalizableIntentOutTestModule
+ implicit none
+
+ type :: AapType
+ integer :: i = 0
+ contains
+ final:: Finalizer
+ end type
+ integer :: ctr = 0
+ logical :: err1 = .false.
+ logical :: err2 = .false.
+contains
+
+ subroutine Finalizer(self)
+ type(AapType), intent(inout) :: self
+
+ ! Fail if Finalizer gets called again on an already finalized object
+ if (self%i == 42) err1 = .true.
+
+ self%i = 42 ! Nobody should ever see this value after finalization
+ ctr = ctr + 1
+ end subroutine
+
+end module
+
+
+program test
+ use FinalizableIntentOutTestModule
+
+ implicit none
+
+ type(AapType) :: aap
+
+ ! Set "i" to nonzero so that initialization in MakeAap has something to do
+ aap%i = 1
+
+ call MakeAap(aap)
+
+ if (err1) stop 1
+ if (err2) stop 2 ! This was failing
+ if (ctr /= 1) stop 3 ! Belt and braces to ensure number of final calls
correct.
+
+contains
+
+ subroutine MakeAap(a)
+ type(AapType), intent(out) :: a
+
+ ! Fail if "a" wasn't initialized properly
+ if (a%i /= 0) err2 = .true.
+ end subroutine
+
+end program
