diff options
author | Andre Vehreschild <vehre@gcc.gnu.org> | 2025-01-29 12:42:18 +0100 |
---|---|---|
committer | Andre Vehreschild <vehre@gcc.gnu.org> | 2025-02-20 10:33:05 +0100 |
commit | 69eb02682b80b84dd0f562f19821c8c8c37ad243 (patch) | |
tree | 5f75429d92cdfb25f7430274faf7e4168cb3e7d5 /gcc/fortran/coarray.cc | |
parent | 15847252648ede9d2ad9eea398b7b870f62a2b30 (diff) | |
download | gcc-69eb02682b80b84dd0f562f19821c8c8c37ad243.zip gcc-69eb02682b80b84dd0f562f19821c8c8c37ad243.tar.gz gcc-69eb02682b80b84dd0f562f19821c8c8c37ad243.tar.bz2 |
Fortran: Add send_to_remote [PR107635]
Refactor to use send_to_remote instead of the slow send_by_ref.
gcc/fortran/ChangeLog:
PR fortran/107635
* coarray.cc (move_coarray_ref): Move the coarray reference out
of the given one. Especially when there is a regular array ref.
(fixup_comp_refs): Move components refs to a derived type where
the codim has been removed, aka a new type.
(split_expr_at_caf_ref): Correctly split the reference chain.
(remove_caf_ref): Simplify.
(create_get_callback): Fix some deficiencies.
(create_allocated_callback): Adapt to new signature of split.
(create_send_callback): New function.
(rewrite_caf_send): Rewrite a call to caf_send to
caf_send_to_remote.
(coindexed_code_callback): Treat caf_send and caf_sendget
correctly.
* gfortran.h (enum gfc_isym_id): Add SENDGET-isym.
* gfortran.texi: Add documentation for send_to_remote.
* resolve.cc (gfc_resolve_code): No longer generate send_by_ref
when allocatable coarray (component) is on the lhs.
* trans-decl.cc (gfc_build_builtin_function_decls): Add
caf_send_to_remote decl.
* trans-intrinsic.cc (conv_caf_func_index): Ensure the static
variables created are not in a block-scope.
(conv_caf_send_to_remote): Translate caf_send_to_remote calls.
(conv_caf_send): Renamed to conv_caf_sendget.
(conv_caf_sendget): Renamed from conv_caf_send.
(gfc_conv_intrinsic_subroutine): Branch correctly for
conv_caf_send and sendget.
* trans.h: Correct decl.
libgfortran/ChangeLog:
* caf/libcaf.h: Add/Correct prototypes for caf_get_from_remote,
caf_send_to_remote.
* caf/single.c (struct accessor_hash_t): Rename accessor_t to
getter_t.
(_gfortran_caf_register_accessor): Use new name of getter_t.
(_gfortran_caf_send_to_remote): New function for sending data to
coarray on a remote image.
gcc/testsuite/ChangeLog:
* gfortran.dg/coarray/send_char_array_1.f90: Extend test to
catch more cases.
* gfortran.dg/coarray_42.f90: Invert tests use, because no
longer a send is needed when local memory in a coarray is
allocated.
Diffstat (limited to 'gcc/fortran/coarray.cc')
-rw-r--r-- | gcc/fortran/coarray.cc | 402 |
1 files changed, 350 insertions, 52 deletions
diff --git a/gcc/fortran/coarray.cc b/gcc/fortran/coarray.cc index c4e637e..5002910 100644 --- a/gcc/fortran/coarray.cc +++ b/gcc/fortran/coarray.cc @@ -243,24 +243,124 @@ convert_coarray_class_to_derived_type (gfc_symbol *base, gfc_namespace *ns) } static void +move_coarray_ref (gfc_ref **from, gfc_expr *expr) +{ + int i; + gfc_ref *to = expr->ref; + for (; to && to->next; to = to->next) + ; + + if (!to) + { + expr->ref = gfc_get_ref (); + to = expr->ref; + to->type = REF_ARRAY; + } + gcc_assert (to->type == REF_ARRAY); + to->u.ar.as = gfc_copy_array_spec ((*from)->u.ar.as); + to->u.ar.codimen = (*from)->u.ar.codimen; + to->u.ar.dimen = (*from)->u.ar.dimen; + to->u.ar.type = AR_FULL; + to->u.ar.stat = (*from)->u.ar.stat; + (*from)->u.ar.stat = nullptr; + to->u.ar.team = (*from)->u.ar.team; + (*from)->u.ar.team = nullptr; + for (i = 0; i < to->u.ar.dimen; ++i) + { + to->u.ar.start[i] = nullptr; + to->u.ar.end[i] = nullptr; + to->u.ar.stride[i] = nullptr; + } + for (i = (*from)->u.ar.dimen; i < (*from)->u.ar.dimen + (*from)->u.ar.codimen; + ++i) + { + to->u.ar.dimen_type[i] = (*from)->u.ar.dimen_type[i]; + to->u.ar.start[i] = (*from)->u.ar.start[i]; + (*from)->u.ar.start[i] = nullptr; + to->u.ar.end[i] = (*from)->u.ar.end[i]; + (*from)->u.ar.end[i] = nullptr; + to->u.ar.stride[i] = (*from)->u.ar.stride[i]; + (*from)->u.ar.stride[i] = nullptr; + } + (*from)->u.ar.codimen = 0; + if ((*from)->u.ar.dimen == 0) + { + gfc_ref *nref = (*from)->next; + (*from)->next = nullptr; + gfc_free_ref_list (*from); + *from = nref; + } +} + +static void +fixup_comp_refs (gfc_expr *expr) +{ + gfc_symbol *type = expr->symtree->n.sym->ts.type == BT_DERIVED + ? expr->symtree->n.sym->ts.u.derived + : (expr->symtree->n.sym->ts.type == BT_CLASS + ? CLASS_DATA (expr->symtree->n.sym)->ts.u.derived + : nullptr); + if (!type) + return; + gfc_ref **pref = &(expr->ref); + for (gfc_ref *ref = expr->ref; ref && type;) + { + switch (ref->type) + { + case REF_COMPONENT: + gfc_find_component (type, ref->u.c.component->name, false, true, + pref); + if (!*pref) + { + /* This happens when there were errors previously. Just don't + crash. */ + ref = nullptr; + break; + } + (*pref)->next = ref->next; + ref->next = NULL; + gfc_free_ref_list (ref); + ref = (*pref)->next; + type = (*pref)->u.c.component->ts.type == BT_DERIVED + ? (*pref)->u.c.component->ts.u.derived + : ((*pref)->u.c.component->ts.type == BT_CLASS + ? CLASS_DATA ((*pref)->u.c.component)->ts.u.derived + : nullptr); + pref = &(*pref)->next; + break; + case REF_ARRAY: + pref = &ref->next; + ref = ref->next; + break; + default: + gcc_unreachable (); + break; + } + } +} + +static void split_expr_at_caf_ref (gfc_expr *expr, gfc_namespace *ns, - gfc_expr **post_caf_ref_expr) + gfc_expr **post_caf_ref_expr, bool for_send) { gfc_ref *caf_ref = NULL; gfc_symtree *st; gfc_symbol *base; + gfc_typespec *caf_ts; bool created; gcc_assert (expr->expr_type == EXPR_VARIABLE); + caf_ts = &expr->symtree->n.sym->ts; if (!expr->symtree->n.sym->attr.codimension) { /* The coarray is in some component. Find it. */ caf_ref = expr->ref; while (caf_ref) { - if (caf_ref->type == REF_COMPONENT - && caf_ref->u.c.component->attr.codimension) + if (caf_ref->type == REF_ARRAY && caf_ref->u.ar.codimen != 0) break; + if (caf_ref->type == REF_COMPONENT) + caf_ts = &caf_ref->u.c.component->ts; caf_ref = caf_ref->next; } } @@ -271,7 +371,7 @@ split_expr_at_caf_ref (gfc_expr *expr, gfc_namespace *ns, st->n.sym->attr.flavor = FL_PARAMETER; st->n.sym->attr.dummy = 1; st->n.sym->attr.intent = INTENT_IN; - st->n.sym->ts = caf_ref ? caf_ref->u.c.sym->ts : expr->symtree->n.sym->ts; + st->n.sym->ts = *caf_ts; *post_caf_ref_expr = gfc_get_variable_expr (st); (*post_caf_ref_expr)->where = expr->where; @@ -279,7 +379,12 @@ split_expr_at_caf_ref (gfc_expr *expr, gfc_namespace *ns, if (!caf_ref) { - (*post_caf_ref_expr)->ref = gfc_copy_ref (expr->ref); + (*post_caf_ref_expr)->ref = gfc_get_ref (); + *(*post_caf_ref_expr)->ref = *expr->ref; + expr->ref = nullptr; + move_coarray_ref (&(*post_caf_ref_expr)->ref, expr); + fixup_comp_refs (expr); + if (expr->symtree->n.sym->attr.dimension) { base->as = gfc_copy_array_spec (expr->symtree->n.sym->as); @@ -292,34 +397,39 @@ split_expr_at_caf_ref (gfc_expr *expr, gfc_namespace *ns, } else { - (*post_caf_ref_expr)->ref = gfc_copy_ref (caf_ref->next); - if (caf_ref->u.c.component->attr.dimension) + (*post_caf_ref_expr)->ref = gfc_get_ref (); + *(*post_caf_ref_expr)->ref = *caf_ref; + caf_ref->next = nullptr; + move_coarray_ref (&(*post_caf_ref_expr)->ref, expr); + fixup_comp_refs (expr); + + if (caf_ref && caf_ref->u.ar.dimen) { - base->as = gfc_copy_array_spec (caf_ref->u.c.component->as); + base->as = gfc_copy_array_spec (caf_ref->u.ar.as); base->as->corank = 0; base->attr.dimension = 1; - base->attr.allocatable = caf_ref->u.c.component->attr.allocatable; - base->attr.pointer = caf_ref->u.c.component->attr.pointer; + base->attr.allocatable = caf_ref->u.ar.as->type != AS_EXPLICIT; } - base->ts = caf_ref->u.c.component->ts; + base->ts = *caf_ts; } (*post_caf_ref_expr)->ts = expr->ts; if (base->ts.type == BT_CHARACTER) { base->ts.u.cl = gfc_get_charlen (); - *base->ts.u.cl = *(caf_ref ? caf_ref->u.c.component->ts.u.cl - : expr->symtree->n.sym->ts.u.cl); + *base->ts.u.cl = *(caf_ts->u.cl); base->ts.deferred = 1; base->ts.u.cl->length = nullptr; } - - if (base->ts.type == BT_DERIVED) + else if (base->ts.type == BT_DERIVED) remove_coarray_from_derived_type (base, ns); else if (base->ts.type == BT_CLASS) convert_coarray_class_to_derived_type (base, ns); - gfc_expression_rank (expr); gfc_expression_rank (*post_caf_ref_expr); + if (for_send) + gfc_expression_rank (expr); + else + expr->rank = (*post_caf_ref_expr)->rank; } static void add_caf_get_from_remote (gfc_expr *e); @@ -647,18 +757,16 @@ create_caf_add_data_parameter_type (gfc_expr *expr, gfc_namespace *ns, static void remove_caf_ref (gfc_expr *expr, const bool conv_to_this_image_cafref = false) { - gfc_ref *ref = expr->ref, **pref = &expr->ref; + gfc_ref *ref = expr->ref; while (ref && (ref->type != REF_ARRAY || ref->u.ar.codimen == 0)) { ref = ref->next; - pref = &ref->next; } if (ref && ref->type == REF_ARRAY && ref->u.ar.codimen != 0) { if (ref->u.ar.dimen != 0) { ref->u.ar.codimen = 0; - pref = &ref->next; ref = ref->next; } else @@ -675,21 +783,10 @@ remove_caf_ref (gfc_expr *expr, const bool conv_to_this_image_cafref = false) ref->next = NULL; gfc_free_ref_list (ref); ref = expr->ref; - pref = &expr->ref; } } } - if (ref && ref->type == REF_COMPONENT) - { - gfc_find_component (expr->symtree->n.sym->ts.u.derived, - ref->u.c.component->name, false, true, pref); - if (*pref && *pref != ref) - { - (*pref)->next = ref->next; - ref->next = NULL; - gfc_free_ref_list (ref); - } - } + fixup_comp_refs (expr); } static gfc_expr * @@ -719,7 +816,7 @@ create_get_callback (gfc_expr *expr) mname = expr->symtree->n.sym->module; else mname = "main"; - name = xasprintf ("_caf_rget_%s_%s_%d", mname, tname, ++caf_sym_cnt); + name = xasprintf ("_caf_accessor_%s_%s_%d", mname, tname, ++caf_sym_cnt); gfc_get_symbol (name, ns, &extproc); extproc->declared_at = expr->where; gfc_set_sym_referenced (extproc); @@ -744,7 +841,7 @@ create_get_callback (gfc_expr *expr) gfc_commit_symbol (proc); free (name); - split_expr_at_caf_ref (expr, sub_ns, &post_caf_ref_expr); + split_expr_at_caf_ref (expr, sub_ns, &post_caf_ref_expr, false); if (ns->proc_name->attr.flavor == FL_MODULE) proc->module = ns->proc_name->name; @@ -809,8 +906,7 @@ create_get_callback (gfc_expr *expr) { buffer->ts.u.cl = gfc_get_charlen (); *buffer->ts.u.cl = *expr->ts.u.cl; - buffer->ts.deferred = 1; - buffer->ts.u.cl->length = nullptr; + buffer->ts.u.cl->length = gfc_copy_expr (expr->ts.u.cl->length); } gfc_commit_symbol (buffer); @@ -857,7 +953,7 @@ create_get_callback (gfc_expr *expr) remove_caf_ref (post_caf_ref_expr); get_data->ts.u.derived = create_caf_add_data_parameter_type (code->expr2, ns, get_data); - if (code->expr2->rank == 0) + if (code->expr2->rank == 0 && code->expr2->ts.type != BT_CHARACTER) code->expr2 = gfc_build_intrinsic_call (ns, GFC_ISYM_C_LOC, "C_LOC", gfc_current_locus, 1, code->expr2); @@ -994,7 +1090,7 @@ create_allocated_callback (gfc_expr *expr) free (name); split_expr_at_caf_ref (expr->value.function.actual->expr, sub_ns, - &post_caf_ref_expr); + &post_caf_ref_expr, true); if (ns->proc_name->attr.flavor == FL_MODULE) proc->module = ns->proc_name->name; @@ -1086,10 +1182,198 @@ rewrite_caf_allocated (gfc_expr **e) "caf_is_present_on_remote", (*e)->where, 3, *e, present_hash_expr, present_fn_expr); gfc_add_caf_accessor (present_hash_expr, present_fn_expr); - wrapper->ts = (*e)->ts; *e = wrapper; } +static gfc_expr * +create_send_callback (gfc_expr *expr, gfc_expr *rhs) +{ + gfc_namespace *ns; + gfc_symbol *extproc, *proc, *buffer, *base, *send_data, *caller_image; + char tname[GFC_MAX_SYMBOL_LEN + 1]; + char *name; + const char *mname; + gfc_expr *cb, *post_caf_ref_expr; + gfc_code *code; + gfc_code *backup_caf_accessor_prepend = caf_accessor_prepend; + caf_accessor_prepend = nullptr; + + /* Find the top-level namespace. */ + for (ns = gfc_current_ns; ns->parent; ns = ns->parent) + ; + + if (expr->expr_type == EXPR_VARIABLE) + strcpy (tname, expr->symtree->name); + else + strcpy (tname, "dummy"); + if (expr->symtree->n.sym->module) + mname = expr->symtree->n.sym->module; + else + mname = "main"; + name = xasprintf ("_caf_accessor_%s_%s_%d", mname, tname, ++caf_sym_cnt); + gfc_get_symbol (name, ns, &extproc); + extproc->declared_at = expr->where; + gfc_set_sym_referenced (extproc); + ++extproc->refs; + gfc_commit_symbol (extproc); + + /* Set up namespace. */ + gfc_namespace *sub_ns = gfc_get_namespace (ns, 0); + sub_ns->sibling = ns->contained; + ns->contained = sub_ns; + sub_ns->resolved = 1; + /* Set up procedure symbol. */ + gfc_find_symbol (name, sub_ns, 1, &proc); + sub_ns->proc_name = proc; + proc->attr.if_source = IFSRC_DECL; + proc->attr.access = ACCESS_PUBLIC; + gfc_add_subroutine (&proc->attr, name, NULL); + proc->attr.host_assoc = 1; + proc->attr.always_explicit = 1; + ++proc->refs; + proc->declared_at = expr->where; + gfc_commit_symbol (proc); + free (name); + + split_expr_at_caf_ref (expr, sub_ns, &post_caf_ref_expr, true); + + if (ns->proc_name->attr.flavor == FL_MODULE) + proc->module = ns->proc_name->name; + gfc_set_sym_referenced (proc); + /* Set up formal arguments. */ + gfc_formal_arglist **argptr = &proc->formal; +#define ADD_ARG(name, nsym, stype, skind, sintent) \ + gfc_get_symbol (name, sub_ns, &nsym); \ + nsym->ts.type = stype; \ + nsym->ts.kind = skind; \ + nsym->attr.flavor = FL_PARAMETER; \ + nsym->attr.dummy = 1; \ + nsym->attr.intent = sintent; \ + nsym->declared_at = expr->where; \ + gfc_set_sym_referenced (nsym); \ + *argptr = gfc_get_formal_arglist (); \ + (*argptr)->sym = nsym; \ + argptr = &(*argptr)->next + + name = xasprintf ("add_send_data_%s_%s_%d", mname, tname, caf_sym_cnt); + ADD_ARG (name, send_data, BT_DERIVED, 0, INTENT_IN); + gfc_commit_symbol (send_data); + free (name); + + ADD_ARG ("caller_image", caller_image, BT_INTEGER, gfc_default_integer_kind, + INTENT_IN); + gfc_commit_symbol (caller_image); + + // ADD_ARG (expr->symtree->name, base, BT_VOID, INTENT_IN); + base = post_caf_ref_expr->symtree->n.sym; + base->attr.intent = INTENT_INOUT; + gfc_set_sym_referenced (base); + gfc_commit_symbol (base); + *argptr = gfc_get_formal_arglist (); + (*argptr)->sym = base; + argptr = &(*argptr)->next; + gfc_commit_symbol (base); + + ADD_ARG ("buffer", buffer, rhs->ts.type, rhs->ts.kind, INTENT_IN); + buffer->ts = rhs->ts; + if (rhs->rank) + { + buffer->as = gfc_get_array_spec (); + buffer->as->rank = rhs->rank; + buffer->as->type = AS_DEFERRED; + buffer->attr.allocatable = 1; + buffer->attr.dimension = 1; + } + if (buffer->ts.type == BT_CHARACTER) + { + buffer->ts.u.cl = gfc_get_charlen (); + *buffer->ts.u.cl = *rhs->ts.u.cl; + buffer->ts.deferred = 1; + buffer->ts.u.cl->length = gfc_copy_expr (rhs->ts.u.cl->length); + } + gfc_commit_symbol (buffer); +#undef ADD_ARG + + /* Set up code. */ + /* Code: base = buffer; */ + code = sub_ns->code = gfc_get_code (EXEC_ASSIGN); + code->loc = expr->where; + code->expr1 = post_caf_ref_expr; + if (code->expr1->ts.type == BT_CHARACTER + && code->expr1->ts.kind != buffer->ts.kind) + { + bool converted; + code->expr2 = gfc_lval_expr_from_sym (buffer); + converted = gfc_convert_chartype (code->expr2, &code->expr1->ts); + gcc_assert (converted); + } + else if (code->expr1->ts.type != buffer->ts.type) + { + bool converted; + code->expr2 = gfc_lval_expr_from_sym (buffer); + converted = gfc_convert_type_warn (code->expr2, &code->expr1->ts, 0, 0, + buffer->attr.dimension); + gcc_assert (converted); + } + else + code->expr2 = gfc_lval_expr_from_sym (buffer); + remove_caf_ref (post_caf_ref_expr); + send_data->ts.u.derived + = create_caf_add_data_parameter_type (code->expr1, ns, send_data); + + cb = gfc_lval_expr_from_sym (extproc); + cb->ts.interface = extproc; + + if (caf_accessor_prepend) + { + gfc_code *c = caf_accessor_prepend; + /* Find last in chain. */ + for (; c->next; c = c->next) + ; + c->next = sub_ns->code; + sub_ns->code = caf_accessor_prepend; + } + caf_accessor_prepend = backup_caf_accessor_prepend; + return cb; +} + +static void +rewrite_caf_send (gfc_code *c) +{ + gfc_expr *send_to_remote_expr, *send_to_remote_hash_expr, *lhs, *rhs; + gfc_actual_arglist *arg = c->ext.actual; + + lhs = arg->expr; + arg = arg->next; + rhs = arg->expr; + /* Detect an already rewritten caf_send. */ + if (arg->next && arg->next->expr->expr_type == EXPR_CONSTANT + && arg->next->next && arg->next->next->expr->expr_type == EXPR_VARIABLE) + return; + + if (gfc_is_coindexed (rhs)) + { + c->resolved_isym->id = GFC_ISYM_CAF_SENDGET; + return; + } + + send_to_remote_expr = create_send_callback (lhs, rhs); + send_to_remote_hash_expr = gfc_get_expr (); + send_to_remote_hash_expr->expr_type = EXPR_CONSTANT; + send_to_remote_hash_expr->ts.type = BT_INTEGER; + send_to_remote_hash_expr->ts.kind = gfc_default_integer_kind; + send_to_remote_hash_expr->where = lhs->where; + mpz_init_set_ui (send_to_remote_hash_expr->value.integer, + gfc_hash_value (send_to_remote_expr->symtree->n.sym)); + arg->next = gfc_get_actual_arglist (); + arg = arg->next; + arg->expr = send_to_remote_hash_expr; + arg->next = gfc_get_actual_arglist (); + arg = arg->next; + arg->expr = send_to_remote_expr; + gfc_add_caf_accessor (send_to_remote_hash_expr, send_to_remote_expr); +} + static int coindexed_expr_callback (gfc_expr **e, int *walk_subtrees, void *data ATTRIBUTE_UNUSED) @@ -1158,20 +1442,34 @@ coindexed_code_callback (gfc_code **c, int *walk_subtrees, *walk_subtrees = 0; break; case EXEC_CALL: - *walk_subtrees - = !((*c)->resolved_isym - && ((*c)->resolved_isym->id == GFC_ISYM_CAF_SEND - || (*c)->resolved_isym->id == GFC_ISYM_ATOMIC_ADD - || (*c)->resolved_isym->id == GFC_ISYM_ATOMIC_AND - || (*c)->resolved_isym->id == GFC_ISYM_ATOMIC_CAS - || (*c)->resolved_isym->id == GFC_ISYM_ATOMIC_DEF - || (*c)->resolved_isym->id == GFC_ISYM_ATOMIC_FETCH_ADD - || (*c)->resolved_isym->id == GFC_ISYM_ATOMIC_FETCH_AND - || (*c)->resolved_isym->id == GFC_ISYM_ATOMIC_FETCH_OR - || (*c)->resolved_isym->id == GFC_ISYM_ATOMIC_FETCH_XOR - || (*c)->resolved_isym->id == GFC_ISYM_ATOMIC_OR - || (*c)->resolved_isym->id == GFC_ISYM_ATOMIC_REF - || (*c)->resolved_isym->id == GFC_ISYM_ATOMIC_XOR)); + *walk_subtrees = 1; + if ((*c)->resolved_isym) + switch ((*c)->resolved_isym->id) + { + case GFC_ISYM_CAF_SEND: + rewrite_caf_send (*c); + *walk_subtrees = 0; + break; + case GFC_ISYM_CAF_SENDGET: + // rewrite_caf_sendget (*c); + *walk_subtrees = 0; + break; + case GFC_ISYM_ATOMIC_ADD: + case GFC_ISYM_ATOMIC_AND: + case GFC_ISYM_ATOMIC_CAS: + case GFC_ISYM_ATOMIC_DEF: + case GFC_ISYM_ATOMIC_FETCH_ADD: + case GFC_ISYM_ATOMIC_FETCH_AND: + case GFC_ISYM_ATOMIC_FETCH_OR: + case GFC_ISYM_ATOMIC_FETCH_XOR: + case GFC_ISYM_ATOMIC_OR: + case GFC_ISYM_ATOMIC_REF: + case GFC_ISYM_ATOMIC_XOR: + *walk_subtrees = 0; + break; + default: + break; + } break; default: *walk_subtrees = 1; |