Preparatory work for PR107635.
During resolve prevent adding caf_get calls for expressions on the
left-hand-side of an assignment and removing them later on again.
Furthermore has the caf_token in a component become a pointer to
the component and not the backend_decl of the caf-component.
In some cases the caf_token was added as last component in a derived
type and not as the next one following the component that it was
needed to be associated to.
gcc/fortran/ChangeLog:
PR fortran/107635
* gfortran.h (gfc_comp_caf_token): Convenient macro for
accessing caf_token's tree.
* resolve.cc (gfc_resolve_ref): Backup caf_lhs when resolving
expr in array_ref.
(remove_caf_get_intrinsic): Removed.
(resolve_variable): Set flag caf_lhs when resolving lhs of
assignment to prevent insertion of caf_get.
(resolve_lock_unlock_event): Same, but the lhs is the parameter.
(resolve_ordinary_assign): Move conversion to caf_send to
resolve_codes.
(resolve_codes): Adress caf_get and caf_send here.
(resolve_fl_derived0): Set component's caf_token when token is
necessary.
* trans-array.cc (gfc_conv_array_parameter): Get a coarray for
expression that have a corank.
(structure_alloc_comps): Use macro to get caf_token's tree.
(gfc_alloc_allocatable_for_assignment): Same.
* trans-expr.cc (gfc_get_ultimate_alloc_ptr_comps_caf_token):
Same.
(gfc_trans_structure_assign): Same.
* trans-intrinsic.cc (conv_expr_ref_to_caf_ref): Same.
(has_ref_after_cafref): New function to figure that after a
reference of a coarray another reference is present.
(conv_caf_send): Get rhs from correct place, when caf_get is
not removed.
* trans-types.cc (gfc_get_derived_type): Get caf_token from
component and no longer guessing.
/* Needed for procedure pointer components. */
struct gfc_typebound_proc *tb;
/* When allocatable/pointer and in a coarray the associated token. */
- tree caf_token;
+ struct gfc_component *caf_token;
}
gfc_component;
#define gfc_get_component() XCNEW (gfc_component)
+#define gfc_comp_caf_token(cm) (cm)->caf_token->backend_decl
/* Formal argument lists are lists of symbols. */
typedef struct gfc_formal_arglist
/* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
static bool inquiry_argument = false;
+/* True when we are on left hand side in an assignment of a coarray. */
+static bool caf_lhs = false;
/* Is the symbol host associated? */
static bool
{
int current_part_dimension, n_components, seen_part_dimension, dim;
gfc_ref *ref, **prev, *array_ref;
- bool equal_length;
+ bool equal_length, old_caf_lhs;
for (ref = expr->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY && ref->u.ar.as == NULL)
break;
}
+ old_caf_lhs = caf_lhs;
+ caf_lhs = false;
for (prev = &expr->ref; *prev != NULL;
prev = *prev == NULL ? prev : &(*prev)->next)
switch ((*prev)->type)
{
case REF_ARRAY:
if (!resolve_array_ref (&(*prev)->u.ar))
- return false;
+ {
+ caf_lhs = old_caf_lhs;
+ return false;
+ }
break;
case REF_COMPONENT:
case REF_SUBSTRING:
equal_length = false;
if (!gfc_resolve_substring (*prev, &equal_length))
- return false;
+ {
+ caf_lhs = old_caf_lhs;
+ return false;
+ }
if (expr->expr_type != EXPR_SUBSTRING && equal_length)
{
}
break;
}
+ caf_lhs = old_caf_lhs;
/* Check constraints on part references. */
free (wrapper);
}
-
-static void
-remove_caf_get_intrinsic (gfc_expr *e)
-{
- gcc_assert (e->expr_type == EXPR_FUNCTION && e->value.function.isym
- && e->value.function.isym->id == GFC_ISYM_CAF_GET);
- gfc_expr *e2 = e->value.function.actual->expr;
- e->value.function.actual->expr = NULL;
- gfc_free_actual_arglist (e->value.function.actual);
- gfc_free_shape (&e->shape, e->rank);
- *e = *e2;
- free (e2);
-}
-
-
/* Resolve a variable expression. */
static bool
t = false;
if (sym->as)
- for (n = 0; n < sym->as->rank; n++)
- {
- if (!gfc_resolve_expr (sym->as->lower[n]))
- t = false;
- if (!gfc_resolve_expr (sym->as->upper[n]))
- t = false;
- }
+ {
+ bool old_caf_lhs = caf_lhs;
+ caf_lhs = false;
+ for (n = 0; n < sym->as->rank; n++)
+ {
+ if (!gfc_resolve_expr (sym->as->lower[n]))
+ t = false;
+ if (!gfc_resolve_expr (sym->as->upper[n]))
+ t = false;
+ }
+ caf_lhs = old_caf_lhs;
+ }
specification_expr = saved_specification_expr;
if (t)
if (t)
gfc_expression_rank (e);
- if (t && flag_coarray == GFC_FCOARRAY_LIB && gfc_is_coindexed (e))
+ if (t && flag_coarray == GFC_FCOARRAY_LIB && !caf_lhs
+ && gfc_is_coindexed (e))
add_caf_get_intrinsic (e);
if (sym->attr.ext_attr & (1 << EXT_ATTR_DEPRECATED) && sym != sym->result)
}
}
-
static void
resolve_lock_unlock_event (gfc_code *code)
{
- if (code->expr1->expr_type == EXPR_FUNCTION
- && code->expr1->value.function.isym
- && code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
- remove_caf_get_intrinsic (code->expr1);
-
if ((code->op == EXEC_LOCK || code->op == EXEC_UNLOCK)
&& (code->expr1->ts.type != BT_DERIVED
|| code->expr1->expr_type != EXPR_VARIABLE
if (lhs->ts.type == BT_CLASS && rhs->ts.type != BT_CLASS)
gfc_find_vtab (&rhs->ts);
- bool caf_convert_to_send = flag_coarray == GFC_FCOARRAY_LIB
- && (lhs_coindexed
- || caf_possible_reallocate (lhs)
- || (code->expr2->expr_type == EXPR_FUNCTION
- && code->expr2->value.function.isym
- && code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET
- && (code->expr1->rank == 0 || code->expr2->rank != 0)
- && !gfc_expr_attr (rhs).allocatable
- && !gfc_has_vector_subscript (rhs)));
-
- gfc_check_assign (lhs, rhs, 1, !caf_convert_to_send);
-
- /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a coindexed variable.
- Additionally, insert this code when the RHS is a CAF as we then use the
- GFC_ISYM_CAF_SEND intrinsic just to avoid a temporary; but do not do so if
- the LHS is (re)allocatable or has a vector subscript. If the LHS is a
- noncoindexed array and the RHS is a coindexed scalar, use the normal code
- path. */
- if (caf_convert_to_send)
- {
- if (code->expr2->expr_type == EXPR_FUNCTION
- && code->expr2->value.function.isym
- && code->expr2->value.function.isym->id == GFC_ISYM_CAF_GET)
- remove_caf_get_intrinsic (code->expr2);
- code->op = EXEC_CALL;
- gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree, true);
- code->resolved_sym = code->symtree->n.sym;
- code->resolved_sym->attr.flavor = FL_PROCEDURE;
- code->resolved_sym->attr.intrinsic = 1;
- code->resolved_sym->attr.subroutine = 1;
- code->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
- gfc_commit_symbol (code->resolved_sym);
- code->ext.actual = gfc_get_actual_arglist ();
- code->ext.actual->expr = lhs;
- code->ext.actual->next = gfc_get_actual_arglist ();
- code->ext.actual->next->expr = rhs;
- code->expr1 = NULL;
- code->expr2 = NULL;
- }
+ gfc_check_assign (lhs, rhs, 1);
return false;
}
start:
t = true;
if (code->op != EXEC_COMPCALL && code->op != EXEC_CALL_PPC)
- t = gfc_resolve_expr (code->expr1);
+ {
+ switch (code->op)
+ {
+ case EXEC_ASSIGN:
+ case EXEC_LOCK:
+ case EXEC_UNLOCK:
+ case EXEC_EVENT_POST:
+ case EXEC_EVENT_WAIT:
+ caf_lhs = gfc_is_coindexed (code->expr1);
+ break;
+ default:
+ break;
+ }
+ t = gfc_resolve_expr (code->expr1);
+ caf_lhs = false;
+ }
forall_flag = forall_save;
gfc_do_concurrent_flag = do_concurrent_save;
if (!t)
break;
- if (code->expr1->ts.type == BT_CLASS)
- gfc_find_vtab (&code->expr2->ts);
+ if (flag_coarray == GFC_FCOARRAY_LIB
+ && (gfc_is_coindexed (code->expr1)
+ || caf_possible_reallocate (code->expr1)
+ || (code->expr2->expr_type == EXPR_FUNCTION
+ && code->expr2->value.function.isym
+ && code->expr2->value.function.isym->id
+ == GFC_ISYM_CAF_GET
+ && (code->expr1->rank == 0 || code->expr2->rank != 0)
+ && !gfc_expr_attr (code->expr2).allocatable
+ && !gfc_has_vector_subscript (code->expr2))))
+ {
+ /* Insert a GFC_ISYM_CAF_SEND intrinsic, when the LHS is a
+ coindexed variable. Additionally, insert this code when the
+ RHS is a CAF as we then use the GFC_ISYM_CAF_SEND intrinsic
+ just to avoid a temporary; but do not do so if the LHS is
+ (re)allocatable or has a vector subscript. If the LHS is a
+ noncoindexed array and the RHS is a coindexed scalar, use the
+ normal code path. */
+ code->op = EXEC_CALL;
+ gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree,
+ true);
+ code->resolved_sym = code->symtree->n.sym;
+ code->resolved_sym->attr.flavor = FL_PROCEDURE;
+ code->resolved_sym->attr.intrinsic = 1;
+ code->resolved_sym->attr.subroutine = 1;
+ code->resolved_isym
+ = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
+ gfc_commit_symbol (code->resolved_sym);
+ code->ext.actual = gfc_get_actual_arglist ();
+ code->ext.actual->expr = code->expr1;
+ code->ext.actual->next = gfc_get_actual_arglist ();
+ code->ext.actual->next->expr = code->expr2;
+
+ code->expr1 = NULL;
+ code->expr2 = NULL;
+ break;
+ }
- /* Remove a GFC_ISYM_CAF_GET inserted for a coindexed variable on
- the LHS. */
- if (code->expr1->expr_type == EXPR_FUNCTION
- && code->expr1->value.function.isym
- && code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
- remove_caf_get_intrinsic (code->expr1);
+ if (code->expr1->ts.type == BT_CLASS)
+ gfc_find_vtab (&code->expr2->ts);
/* If this is a pointer function in an lvalue variable context,
the new code will have to be resolved afresh. This is also the
token->attr.artificial = 1;
token->attr.caf_token = 1;
}
+ c->caf_token = token;
}
}
{
/* Every other type of array. */
se->want_pointer = (ctree) ? 0 : 1;
+ se->want_coarray = expr->corank;
gfc_conv_expr_descriptor (se, expr);
if (size)
&& caf_dereg_mode != GFC_CAF_COARRAY_NOCOARRAY)
{
if (c->caf_token)
- caf_token = fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (c->caf_token),
- decl, c->caf_token, NULL_TREE);
+ caf_token
+ = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (gfc_comp_caf_token (c)),
+ decl, gfc_comp_caf_token (c),
+ NULL_TREE);
else if (attr->dimension && !attr->proc_pointer)
caf_token = gfc_conv_descriptor_token (comp);
}
gfc_init_se (&se, NULL);
token = fold_build3_loc (input_location, COMPONENT_REF,
- pvoid_type_node, decl, c->caf_token,
- NULL_TREE);
+ pvoid_type_node, decl,
+ gfc_comp_caf_token (c), NULL_TREE);
comp = gfc_conv_scalar_to_descriptor (&se, comp,
c->ts.type == BT_CLASS
? CLASS_DATA (c)->attr
dst_tok = gfc_conv_descriptor_token (dcmp);
else
{
- /* For a scalar allocatable component the caf_token is
- the next component. */
- if (!c->caf_token)
- c->caf_token = c->next->backend_decl;
- dst_tok = fold_build3_loc (input_location,
- COMPONENT_REF,
- pvoid_type_node, dest,
- c->caf_token,
- NULL_TREE);
+ dst_tok
+ = fold_build3_loc (input_location, COMPONENT_REF,
+ pvoid_type_node, dest,
+ gfc_comp_caf_token (c), NULL_TREE);
}
tmp
= duplicate_allocatable_coarray (dcmp, dst_tok, comp, ctype,
else if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->backend_decl)
{
tmp = TYPE_SIZE_UNIT (TREE_TYPE (gfc_typenode_for_spec (&expr1->ts)));
- tmp = fold_build2_loc (input_location, MULT_EXPR,
- gfc_array_index_type, tmp,
+ tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ fold_convert (gfc_array_index_type, tmp),
expr1->ts.u.cl->backend_decl);
}
else if (UNLIMITED_POLY (expr1) && expr2->ts.type != BT_CLASS)
if (last_caf_ref == NULL)
return NULL_TREE;
- tree comp = last_caf_ref->u.c.component->caf_token, caf;
+ tree comp = last_caf_ref->u.c.component->caf_token
+ ? gfc_comp_caf_token (last_caf_ref->u.c.component)
+ : NULL_TREE,
+ caf;
gfc_se se;
bool comp_ref = !last_caf_ref->u.c.component->attr.dimension;
if (comp == NULL_TREE && comp_ref)
if (cm->ts.type == BT_CLASS)
field = gfc_class_data_get (field);
- token = is_array ? gfc_conv_descriptor_token (field)
- : fold_build3_loc (input_location, COMPONENT_REF,
- TREE_TYPE (cm->caf_token), dest,
- cm->caf_token, NULL_TREE);
+ token
+ = is_array
+ ? gfc_conv_descriptor_token (field)
+ : fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (gfc_comp_caf_token (cm)), dest,
+ gfc_comp_caf_token (cm), NULL_TREE);
if (is_array)
{
arr_desc_token_offset);
}
else if (ref->u.c.component->caf_token)
- tmp2 = compute_component_offset (ref->u.c.component->caf_token,
+ tmp2 = compute_component_offset (gfc_comp_caf_token (
+ ref->u.c.component),
TREE_TYPE (tmp));
else
tmp2 = integer_zero_node;
se->string_length = argse.string_length;
}
+static bool
+has_ref_after_cafref (gfc_expr *expr)
+{
+ for (gfc_ref *ref = expr->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->u.ar.codimen)
+ return ref->next;
+ return false;
+}
/* Send data to a remote coarray. */
gcc_assert (flag_coarray == GFC_FCOARRAY_LIB);
- lhs_expr = code->ext.actual->expr;
- rhs_expr = code->ext.actual->next->expr;
+ lhs_expr
+ = code->ext.actual->expr->expr_type == EXPR_FUNCTION
+ && code->ext.actual->expr->value.function.isym->id == GFC_ISYM_CAF_GET
+ ? code->ext.actual->expr->value.function.actual->expr
+ : code->ext.actual->expr;
+ rhs_expr = code->ext.actual->next->expr->expr_type == EXPR_FUNCTION
+ && code->ext.actual->next->expr->value.function.isym->id
+ == GFC_ISYM_CAF_GET
+ ? code->ext.actual->next->expr->value.function.actual->expr
+ : code->ext.actual->next->expr;
lhs_is_coindexed = gfc_is_coindexed (lhs_expr);
rhs_is_coindexed = gfc_is_coindexed (rhs_expr);
may_require_tmp = gfc_check_dependency (lhs_expr, rhs_expr, true) == 0
gfc_add_block_to_block (&block, &lhs_se.post);
return gfc_finish_block (&block);
}
+ else if (rhs_expr->expr_type == EXPR_FUNCTION
+ && rhs_expr->value.function.isym->id == GFC_ISYM_CAF_GET)
+ rhs_expr = rhs_expr->value.function.actual->expr;
gfc_add_block_to_block (&block, &lhs_se.pre);
if (!rhs_is_coindexed)
{
- if (lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp)
+ if (lhs_caf_attr.alloc_comp || lhs_caf_attr.pointer_comp
+ || has_ref_after_cafref (lhs_expr))
{
tree reference, dst_realloc;
reference = conv_expr_ref_to_caf_ref (&block, lhs_expr);
caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
rhs_image_index = gfc_caf_get_image_index (&block, rhs_expr, caf_decl);
tmp = rhs_se.expr;
- if (rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp)
+ if (rhs_caf_attr.alloc_comp || rhs_caf_attr.pointer_comp
+ || has_ref_after_cafref (lhs_expr))
{
tmp_stat = gfc_find_stat_co (lhs_expr);
tree *chain = NULL;
bool got_canonical = false;
bool unlimited_entity = false;
- gfc_component *c, *last_c = nullptr;
+ gfc_component *c;
gfc_namespace *ns;
tree tmp;
bool coarray_flag, class_coarray_flag;
gcc_assert (field);
/* Overwrite for class array to supply different bounds for different
types. */
- if (class_coarray_flag || !c->backend_decl)
+ if (class_coarray_flag || !c->backend_decl || c->attr.caf_token)
c->backend_decl = field;
- if (c->attr.caf_token && last_c)
- last_c->caf_token = field;
if (c->attr.pointer && (c->attr.dimension || c->attr.codimension)
&& !(c->ts.type == BT_DERIVED && strcmp (c->name, "_data") == 0))
GFC_DECL_PTR_ARRAY_P (c->backend_decl) = 1;
-
- last_c = c;
}
/* Now lay out the derived type, including the fields. */
copy_derived_types:
- for (c = derived->components; c; c = c->next)
- {
- /* Do not add a caf_token field for class container components. */
- if ((codimen || coarray_flag)
- && !c->attr.dimension && !c->attr.codimension
- && (c->attr.allocatable || c->attr.pointer)
- && !derived->attr.is_class)
- {
- /* Provide sufficient space to hold "_caf_symbol". */
- char caf_name[GFC_MAX_SYMBOL_LEN + 6];
- gfc_component *token;
- snprintf (caf_name, sizeof (caf_name), "_caf_%s", c->name);
- token = gfc_find_component (derived, caf_name, true, true, NULL);
- gcc_assert (token);
- c->caf_token = token->backend_decl;
- suppress_warning (c->caf_token);
- }
- }
+ if (!derived->attr.vtype)
+ for (c = derived->components; c; c = c->next)
+ {
+ /* Do not add a caf_token field for class container components. */
+ if ((codimen || coarray_flag) && !c->attr.dimension
+ && !c->attr.codimension && (c->attr.allocatable || c->attr.pointer)
+ && !derived->attr.is_class)
+ {
+ /* Provide sufficient space to hold "_caf_symbol". */
+ char caf_name[GFC_MAX_SYMBOL_LEN + 6];
+ gfc_component *token;
+ snprintf (caf_name, sizeof (caf_name), "_caf_%s", c->name);
+ token = gfc_find_component (derived, caf_name, true, true, NULL);
+ gcc_assert (token);
+ gfc_comp_caf_token (c) = token->backend_decl;
+ suppress_warning (gfc_comp_caf_token (c));
+ }
+ }
for (gfc_symbol *dt = gfc_derived_types; dt; dt = dt->dt_next)
{
projects / thirdparty / gcc.git / commitdiff
