Fortran: Store OpenMP's 'declare variant' in module file [PR115271]
Write the 'omp declare variant' data into the .mod file: Base function, variant function(s), supporting the clauses match, append_args, and adjust_args. PR fortran/115271 gcc/fortran/ChangeLog: * module.cc (mio_omp_declare_simd_clauses): New, moved from ... (mio_omp_declare_simd): ... here. Update call, write empty '( )' if there is no declare simd but a declare variant. (mio_omp_declare_variant): New. (mio_symbol): Call it. * openmp.cc (gfc_match_omp_context_selector): Add comment about module.cc to TODO note. * trans-stmt.h (gfc_trans_omp_declare_variant): Take additional parent_ns argument. * trans-decl.cc (create_function_arglist, gfc_create_function_decl): Update call. * trans-openmp.cc (gfc_trans_omp_declare_variant): Take new argument, add some special case handling for attr.use_assoc. gcc/testsuite/ChangeLog: * gfortran.dg/gomp/declare-variant-mod-1-use.f90: New test. * gfortran.dg/gomp/declare-variant-mod-1.f90: New test. * gfortran.dg/gomp/declare-variant-mod-2-use.f90: New test. * gfortran.dg/gomp/declare-variant-mod-2.f90: New test.
This commit is contained in:
Tobias Burnus
parent
f70f4b60de
commit
6f3bca0db8
9 changed files with 651 additions and 67 deletions
|
|
@ -4381,75 +4381,58 @@ static const mstring omp_declare_simd_clauses[] =
|
|||
minit (NULL, -1)
|
||||
};
|
||||
|
||||
/* Handle !$omp declare simd. */
|
||||
/* Handle OpenMP's declare-simd clauses. */
|
||||
|
||||
static void
|
||||
mio_omp_declare_simd (gfc_namespace *ns, gfc_omp_declare_simd **odsp)
|
||||
mio_omp_declare_simd_clauses (gfc_omp_clauses **clausesp)
|
||||
{
|
||||
if (iomode == IO_OUTPUT)
|
||||
{
|
||||
if (*odsp == NULL)
|
||||
return;
|
||||
}
|
||||
else if (peek_atom () != ATOM_LPAREN)
|
||||
return;
|
||||
gfc_omp_clauses *clauses = *clausesp;
|
||||
gfc_omp_namelist *n;
|
||||
|
||||
gfc_omp_declare_simd *ods = *odsp;
|
||||
|
||||
mio_lparen ();
|
||||
if (iomode == IO_OUTPUT)
|
||||
{
|
||||
write_atom (ATOM_NAME, "OMP_DECLARE_SIMD");
|
||||
if (ods->clauses)
|
||||
if (clauses->inbranch)
|
||||
mio_name (0, omp_declare_simd_clauses);
|
||||
if (clauses->notinbranch)
|
||||
mio_name (1, omp_declare_simd_clauses);
|
||||
if (clauses->simdlen_expr)
|
||||
{
|
||||
gfc_omp_namelist *n;
|
||||
|
||||
if (ods->clauses->inbranch)
|
||||
mio_name (0, omp_declare_simd_clauses);
|
||||
if (ods->clauses->notinbranch)
|
||||
mio_name (1, omp_declare_simd_clauses);
|
||||
if (ods->clauses->simdlen_expr)
|
||||
{
|
||||
mio_name (2, omp_declare_simd_clauses);
|
||||
mio_expr (&ods->clauses->simdlen_expr);
|
||||
}
|
||||
for (n = ods->clauses->lists[OMP_LIST_UNIFORM]; n; n = n->next)
|
||||
{
|
||||
mio_name (3, omp_declare_simd_clauses);
|
||||
mio_symbol_ref (&n->sym);
|
||||
}
|
||||
for (n = ods->clauses->lists[OMP_LIST_LINEAR]; n; n = n->next)
|
||||
{
|
||||
if (n->u.linear.op == OMP_LINEAR_DEFAULT)
|
||||
mio_name (4, omp_declare_simd_clauses);
|
||||
else
|
||||
mio_name (32 + n->u.linear.op, omp_declare_simd_clauses);
|
||||
mio_symbol_ref (&n->sym);
|
||||
mio_expr (&n->expr);
|
||||
}
|
||||
for (n = ods->clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
|
||||
{
|
||||
mio_name (5, omp_declare_simd_clauses);
|
||||
mio_symbol_ref (&n->sym);
|
||||
mio_expr (&n->expr);
|
||||
}
|
||||
mio_name (2, omp_declare_simd_clauses);
|
||||
mio_expr (&clauses->simdlen_expr);
|
||||
}
|
||||
for (n = clauses->lists[OMP_LIST_UNIFORM]; n; n = n->next)
|
||||
{
|
||||
mio_name (3, omp_declare_simd_clauses);
|
||||
mio_symbol_ref (&n->sym);
|
||||
}
|
||||
for (n = clauses->lists[OMP_LIST_LINEAR]; n; n = n->next)
|
||||
{
|
||||
if (n->u.linear.op == OMP_LINEAR_DEFAULT)
|
||||
mio_name (4, omp_declare_simd_clauses);
|
||||
else
|
||||
mio_name (32 + n->u.linear.op, omp_declare_simd_clauses);
|
||||
mio_symbol_ref (&n->sym);
|
||||
mio_expr (&n->expr);
|
||||
}
|
||||
for (n = clauses->lists[OMP_LIST_ALIGNED]; n; n = n->next)
|
||||
{
|
||||
mio_name (5, omp_declare_simd_clauses);
|
||||
mio_symbol_ref (&n->sym);
|
||||
mio_expr (&n->expr);
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
gfc_omp_namelist **ptrs[3] = { NULL, NULL, NULL };
|
||||
if (peek_atom () != ATOM_NAME)
|
||||
return;
|
||||
|
||||
gfc_omp_namelist **ptrs[3] = { NULL, NULL, NULL };
|
||||
gfc_omp_clauses *clauses = *clausesp = gfc_get_omp_clauses ();
|
||||
ptrs[0] = &clauses->lists[OMP_LIST_UNIFORM];
|
||||
ptrs[1] = &clauses->lists[OMP_LIST_LINEAR];
|
||||
ptrs[2] = &clauses->lists[OMP_LIST_ALIGNED];
|
||||
|
||||
require_atom (ATOM_NAME);
|
||||
*odsp = ods = gfc_get_omp_declare_simd ();
|
||||
ods->where = gfc_current_locus;
|
||||
ods->proc_name = ns->proc_name;
|
||||
if (peek_atom () == ATOM_NAME)
|
||||
{
|
||||
ods->clauses = gfc_get_omp_clauses ();
|
||||
ptrs[0] = &ods->clauses->lists[OMP_LIST_UNIFORM];
|
||||
ptrs[1] = &ods->clauses->lists[OMP_LIST_LINEAR];
|
||||
ptrs[2] = &ods->clauses->lists[OMP_LIST_ALIGNED];
|
||||
}
|
||||
while (peek_atom () == ATOM_NAME)
|
||||
{
|
||||
gfc_omp_namelist *n;
|
||||
|
|
@ -4457,9 +4440,9 @@ mio_omp_declare_simd (gfc_namespace *ns, gfc_omp_declare_simd **odsp)
|
|||
|
||||
switch (t)
|
||||
{
|
||||
case 0: ods->clauses->inbranch = true; break;
|
||||
case 1: ods->clauses->notinbranch = true; break;
|
||||
case 2: mio_expr (&ods->clauses->simdlen_expr); break;
|
||||
case 0: clauses->inbranch = true; break;
|
||||
case 1: clauses->notinbranch = true; break;
|
||||
case 2: mio_expr (&clauses->simdlen_expr); break;
|
||||
case 3:
|
||||
case 4:
|
||||
case 5:
|
||||
|
|
@ -4481,12 +4464,309 @@ mio_omp_declare_simd (gfc_namespace *ns, gfc_omp_declare_simd **odsp)
|
|||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
/* Handle !$omp declare simd. */
|
||||
|
||||
static void
|
||||
mio_omp_declare_simd (gfc_namespace *ns, gfc_omp_declare_simd **odsp)
|
||||
{
|
||||
if (iomode == IO_OUTPUT)
|
||||
{
|
||||
if (*odsp == NULL)
|
||||
{
|
||||
if (ns->omp_declare_variant)
|
||||
{
|
||||
mio_lparen ();
|
||||
mio_rparen ();
|
||||
}
|
||||
return;
|
||||
}
|
||||
}
|
||||
else if (peek_atom () != ATOM_LPAREN)
|
||||
return;
|
||||
|
||||
gfc_omp_declare_simd *ods = *odsp;
|
||||
|
||||
mio_lparen ();
|
||||
if (iomode == IO_OUTPUT)
|
||||
{
|
||||
if (ods->clauses)
|
||||
mio_omp_declare_simd_clauses (&ods->clauses);
|
||||
}
|
||||
else
|
||||
{
|
||||
if (peek_atom () == ATOM_RPAREN)
|
||||
{
|
||||
mio_rparen ();
|
||||
return;
|
||||
}
|
||||
|
||||
require_atom (ATOM_NAME);
|
||||
*odsp = ods = gfc_get_omp_declare_simd ();
|
||||
ods->where = gfc_current_locus;
|
||||
ods->proc_name = ns->proc_name;
|
||||
mio_omp_declare_simd_clauses (&ods->clauses);
|
||||
}
|
||||
|
||||
mio_omp_declare_simd (ns, &ods->next);
|
||||
|
||||
mio_rparen ();
|
||||
}
|
||||
|
||||
/* Handle !$omp declare variant. */
|
||||
|
||||
static void
|
||||
mio_omp_declare_variant (gfc_namespace *ns, gfc_omp_declare_variant **odvp)
|
||||
{
|
||||
if (iomode == IO_OUTPUT)
|
||||
{
|
||||
if (*odvp == NULL)
|
||||
return;
|
||||
}
|
||||
else if (peek_atom () != ATOM_LPAREN)
|
||||
return;
|
||||
|
||||
gfc_omp_declare_variant *odv;
|
||||
|
||||
mio_lparen ();
|
||||
if (iomode == IO_OUTPUT)
|
||||
{
|
||||
odv = *odvp;
|
||||
write_atom (ATOM_NAME, "OMP_DECLARE_VARIANT");
|
||||
gfc_symtree *st;
|
||||
st = (odv->base_proc_symtree
|
||||
? odv->base_proc_symtree
|
||||
: gfc_find_symtree (ns->sym_root, ns->proc_name->name));
|
||||
mio_symtree_ref (&st);
|
||||
st = (st->n.sym->attr.if_source == IFSRC_IFBODY
|
||||
&& st->n.sym->formal_ns == ns
|
||||
? gfc_find_symtree (ns->parent->sym_root,
|
||||
odv->variant_proc_symtree->name)
|
||||
: odv->variant_proc_symtree);
|
||||
mio_symtree_ref (&st);
|
||||
|
||||
mio_lparen ();
|
||||
write_atom (ATOM_NAME, "SEL");
|
||||
for (gfc_omp_set_selector *set = odv->set_selectors; set; set = set->next)
|
||||
{
|
||||
int set_code = set->code;
|
||||
mio_integer (&set_code);
|
||||
mio_lparen ();
|
||||
for (gfc_omp_selector *sel = set->trait_selectors; sel;
|
||||
sel = sel->next)
|
||||
{
|
||||
int sel_code = sel->code;
|
||||
mio_integer (&sel_code);
|
||||
mio_expr (&sel->score);
|
||||
mio_lparen ();
|
||||
for (gfc_omp_trait_property *prop = sel->properties; prop;
|
||||
prop = prop->next)
|
||||
{
|
||||
int kind = prop->property_kind;
|
||||
mio_integer (&kind);
|
||||
int is_name = prop->is_name;
|
||||
mio_integer (&is_name);
|
||||
switch (prop->property_kind)
|
||||
{
|
||||
case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR:
|
||||
case OMP_TRAIT_PROPERTY_BOOL_EXPR:
|
||||
mio_expr (&prop->expr);
|
||||
break;
|
||||
case OMP_TRAIT_PROPERTY_ID:
|
||||
write_atom (ATOM_STRING, prop->name);
|
||||
break;
|
||||
case OMP_TRAIT_PROPERTY_NAME_LIST:
|
||||
if (prop->is_name)
|
||||
write_atom (ATOM_STRING, prop->name);
|
||||
else
|
||||
mio_expr (&prop->expr);
|
||||
break;
|
||||
case OMP_TRAIT_PROPERTY_CLAUSE_LIST:
|
||||
{
|
||||
/* Currently only declare simd. */
|
||||
mio_lparen ();
|
||||
mio_omp_declare_simd_clauses (&prop->clauses);
|
||||
mio_rparen ();
|
||||
}
|
||||
break;
|
||||
default:
|
||||
gcc_unreachable ();
|
||||
}
|
||||
}
|
||||
mio_rparen ();
|
||||
}
|
||||
mio_rparen ();
|
||||
}
|
||||
mio_rparen ();
|
||||
|
||||
mio_lparen ();
|
||||
write_atom (ATOM_NAME, "ADJ");
|
||||
for (gfc_omp_namelist *arg = odv->adjust_args_list; arg; arg = arg->next)
|
||||
{
|
||||
int need_ptr = arg->u.adj_args.need_ptr;
|
||||
int need_addr = arg->u.adj_args.need_addr;
|
||||
int range_start = arg->u.adj_args.range_start;
|
||||
int omp_num_args_plus = arg->u.adj_args.omp_num_args_plus;
|
||||
int omp_num_args_minus = arg->u.adj_args.omp_num_args_minus;
|
||||
mio_integer (&need_ptr);
|
||||
mio_integer (&need_addr);
|
||||
mio_integer (&range_start);
|
||||
mio_integer (&omp_num_args_plus);
|
||||
mio_integer (&omp_num_args_minus);
|
||||
mio_expr (&arg->expr);
|
||||
}
|
||||
mio_rparen ();
|
||||
|
||||
mio_lparen ();
|
||||
write_atom (ATOM_NAME, "APP");
|
||||
for (gfc_omp_namelist *arg = odv->append_args_list; arg; arg = arg->next)
|
||||
{
|
||||
int target = arg->u.init.target;
|
||||
int targetsync = arg->u.init.targetsync;
|
||||
mio_integer (&target);
|
||||
mio_integer (&targetsync);
|
||||
mio_integer (&arg->u.init.len);
|
||||
gfc_char_t *p = XALLOCAVEC (gfc_char_t, arg->u.init.len);
|
||||
for (int i = 0; i < arg->u.init.len; i++)
|
||||
p[i] = arg->u2.init_interop[i];
|
||||
mio_allocated_wide_string (p, arg->u.init.len);
|
||||
}
|
||||
mio_rparen ();
|
||||
}
|
||||
else
|
||||
{
|
||||
if (peek_atom () == ATOM_RPAREN)
|
||||
{
|
||||
mio_rparen ();
|
||||
return;
|
||||
}
|
||||
|
||||
require_atom (ATOM_NAME);
|
||||
odv = *odvp = gfc_get_omp_declare_variant ();
|
||||
odv->where = gfc_current_locus;
|
||||
|
||||
mio_symtree_ref (&odv->base_proc_symtree);
|
||||
mio_symtree_ref (&odv->variant_proc_symtree);
|
||||
|
||||
mio_lparen ();
|
||||
require_atom (ATOM_NAME); /* SEL */
|
||||
gfc_omp_set_selector **set = &odv->set_selectors;
|
||||
while (peek_atom () != ATOM_RPAREN)
|
||||
{
|
||||
*set = gfc_get_omp_set_selector ();
|
||||
int set_code;
|
||||
mio_integer (&set_code);
|
||||
(*set)->code = (enum omp_tss_code) set_code;
|
||||
|
||||
mio_lparen ();
|
||||
gfc_omp_selector **sel = &(*set)->trait_selectors;
|
||||
while (peek_atom () != ATOM_RPAREN)
|
||||
{
|
||||
*sel = gfc_get_omp_selector ();
|
||||
int sel_code = 0;
|
||||
mio_integer (&sel_code);
|
||||
(*sel)->code = (enum omp_ts_code) sel_code;
|
||||
mio_expr (&(*sel)->score);
|
||||
|
||||
mio_lparen ();
|
||||
gfc_omp_trait_property **prop = &(*sel)->properties;
|
||||
while (peek_atom () != ATOM_RPAREN)
|
||||
{
|
||||
*prop = gfc_get_omp_trait_property ();
|
||||
int kind = 0, is_name = 0;
|
||||
mio_integer (&kind);
|
||||
mio_integer (&is_name);
|
||||
(*prop)->property_kind = (enum omp_tp_type) kind;
|
||||
(*prop)->is_name = is_name;
|
||||
switch ((*prop)->property_kind)
|
||||
{
|
||||
case OMP_TRAIT_PROPERTY_DEV_NUM_EXPR:
|
||||
case OMP_TRAIT_PROPERTY_BOOL_EXPR:
|
||||
mio_expr (&(*prop)->expr);
|
||||
break;
|
||||
case OMP_TRAIT_PROPERTY_ID:
|
||||
(*prop)->name = read_string ();
|
||||
break;
|
||||
case OMP_TRAIT_PROPERTY_NAME_LIST:
|
||||
if ((*prop)->is_name)
|
||||
(*prop)->name = read_string ();
|
||||
else
|
||||
mio_expr (&(*prop)->expr);
|
||||
break;
|
||||
case OMP_TRAIT_PROPERTY_CLAUSE_LIST:
|
||||
{
|
||||
/* Currently only declare simd. */
|
||||
mio_lparen ();
|
||||
mio_omp_declare_simd_clauses (&(*prop)->clauses);
|
||||
mio_rparen ();
|
||||
}
|
||||
break;
|
||||
default:
|
||||
gcc_unreachable ();
|
||||
}
|
||||
prop = &(*prop)->next;
|
||||
}
|
||||
mio_rparen ();
|
||||
sel = &(*sel)->next;
|
||||
}
|
||||
mio_rparen ();
|
||||
set = &(*set)->next;
|
||||
}
|
||||
mio_rparen ();
|
||||
|
||||
mio_lparen ();
|
||||
require_atom (ATOM_NAME); /* ADJ */
|
||||
gfc_omp_namelist **nl = &odv->adjust_args_list;
|
||||
while (peek_atom () != ATOM_RPAREN)
|
||||
{
|
||||
*nl = gfc_get_omp_namelist ();
|
||||
(*nl)->where = gfc_current_locus;
|
||||
int need_ptr, need_addr, range_start;
|
||||
int omp_num_args_plus, omp_num_args_minus;
|
||||
mio_integer (&need_ptr);
|
||||
mio_integer (&need_addr);
|
||||
mio_integer (&range_start);
|
||||
mio_integer (&omp_num_args_plus);
|
||||
mio_integer (&omp_num_args_minus);
|
||||
(*nl)->u.adj_args.need_ptr = need_ptr;
|
||||
(*nl)->u.adj_args.need_addr = need_addr;
|
||||
(*nl)->u.adj_args.range_start = range_start;
|
||||
(*nl)->u.adj_args.omp_num_args_plus = omp_num_args_minus;
|
||||
(*nl)->u.adj_args.omp_num_args_plus = omp_num_args_minus;
|
||||
mio_expr (&(*nl)->expr);
|
||||
nl = &(*nl)->next;
|
||||
}
|
||||
mio_rparen ();
|
||||
|
||||
mio_lparen ();
|
||||
require_atom (ATOM_NAME); /* APP */
|
||||
nl = &odv->append_args_list;
|
||||
while (peek_atom () != ATOM_RPAREN)
|
||||
{
|
||||
*nl = gfc_get_omp_namelist ();
|
||||
(*nl)->where = gfc_current_locus;
|
||||
int target, targetsync;
|
||||
mio_integer (&target);
|
||||
mio_integer (&targetsync);
|
||||
mio_integer (&(*nl)->u.init.len);
|
||||
(*nl)->u.init.target = target;
|
||||
(*nl)->u.init.targetsync = targetsync;
|
||||
const gfc_char_t *p = XALLOCAVEC (gfc_char_t, (*nl)->u.init.len); // FIXME: memory handling?
|
||||
(*nl)->u2.init_interop = XCNEWVEC (char, (*nl)->u.init.len);
|
||||
p = mio_allocated_wide_string (NULL, (*nl)->u.init.len);
|
||||
for (int i = 0; i < (*nl)->u.init.len; i++)
|
||||
(*nl)->u2.init_interop[i] = p[i];
|
||||
nl = &(*nl)->next;
|
||||
}
|
||||
mio_rparen ();
|
||||
}
|
||||
|
||||
mio_omp_declare_variant (ns, &odv->next);
|
||||
|
||||
mio_rparen ();
|
||||
}
|
||||
|
||||
static const mstring omp_declare_reduction_stmt[] =
|
||||
{
|
||||
|
|
@ -4665,7 +4945,14 @@ mio_symbol (gfc_symbol *sym)
|
|||
if (sym->formal_ns
|
||||
&& sym->formal_ns->proc_name == sym
|
||||
&& sym->formal_ns->entries == NULL)
|
||||
mio_omp_declare_simd (sym->formal_ns, &sym->formal_ns->omp_declare_simd);
|
||||
{
|
||||
mio_omp_declare_simd (sym->formal_ns, &sym->formal_ns->omp_declare_simd);
|
||||
mio_omp_declare_variant (sym->formal_ns,
|
||||
&sym->formal_ns->omp_declare_variant);
|
||||
}
|
||||
else if ((iomode == IO_OUTPUT && sym->ns->proc_name == sym)
|
||||
|| (iomode == IO_INPUT && peek_atom () == ATOM_LPAREN))
|
||||
mio_omp_declare_variant (sym->ns, &sym->ns->omp_declare_variant);
|
||||
|
||||
mio_rparen ();
|
||||
}
|
||||
|
|
|
|||
|
|
@ -6535,7 +6535,8 @@ gfc_match_omp_context_selector (gfc_omp_set_selector *oss,
|
|||
{
|
||||
/* FIXME: The "requires" selector was added in OpenMP 5.1.
|
||||
Currently only the now-deprecated syntax
|
||||
from OpenMP 5.0 is supported. */
|
||||
from OpenMP 5.0 is supported.
|
||||
TODO: When implementing, update modules.cc as well. */
|
||||
sorry_at (gfc_get_location (&gfc_current_locus),
|
||||
"%<requires%> selector is not supported yet");
|
||||
return MATCH_ERROR;
|
||||
|
|
|
|||
|
|
@ -2481,7 +2481,7 @@ module_sym:
|
|||
// We need DECL_ARGUMENTS to put attributes on, in case some arguments
|
||||
// need adjustment
|
||||
create_function_arglist (sym->formal_ns->proc_name);
|
||||
gfc_trans_omp_declare_variant (sym->formal_ns);
|
||||
gfc_trans_omp_declare_variant (sym->formal_ns, sym->ns);
|
||||
}
|
||||
}
|
||||
|
||||
|
|
@ -3269,7 +3269,7 @@ gfc_create_function_decl (gfc_namespace * ns, bool global)
|
|||
be declared in a parent namespace, so this needs to be called even if
|
||||
there are no local directives. */
|
||||
if (flag_openmp)
|
||||
gfc_trans_omp_declare_variant (ns);
|
||||
gfc_trans_omp_declare_variant (ns, NULL);
|
||||
}
|
||||
|
||||
/* Return the decl used to hold the function return value. If
|
||||
|
|
|
|||
|
|
@ -8697,9 +8697,11 @@ gfc_trans_omp_set_selector (gfc_omp_set_selector *gfc_selectors, locus where)
|
|||
return set_selectors;
|
||||
}
|
||||
|
||||
/* If 'ns' points to a formal namespace in an interface, ns->parent == NULL;
|
||||
hence, parent_ns is used instead. */
|
||||
|
||||
void
|
||||
gfc_trans_omp_declare_variant (gfc_namespace *ns)
|
||||
gfc_trans_omp_declare_variant (gfc_namespace *ns, gfc_namespace *parent_ns)
|
||||
{
|
||||
tree base_fn_decl = ns->proc_name->backend_decl;
|
||||
gfc_namespace *search_ns = ns;
|
||||
|
|
@ -8712,7 +8714,10 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns)
|
|||
current namespace. */
|
||||
if (!odv)
|
||||
{
|
||||
search_ns = search_ns->parent;
|
||||
if (!search_ns->parent && search_ns == ns)
|
||||
search_ns = parent_ns;
|
||||
else
|
||||
search_ns = search_ns->parent;
|
||||
if (search_ns)
|
||||
next = search_ns->omp_declare_variant;
|
||||
continue;
|
||||
|
|
@ -8740,6 +8745,7 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns)
|
|||
else
|
||||
{
|
||||
if (!search_ns->contained
|
||||
&& !odv->base_proc_symtree->n.sym->attr.use_assoc
|
||||
&& strcmp (odv->base_proc_symtree->name,
|
||||
ns->proc_name->name))
|
||||
gfc_error ("The base name at %L does not match the name of the "
|
||||
|
|
@ -8770,7 +8776,12 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns)
|
|||
/* Ignore directives that do not apply to the current procedure. */
|
||||
if ((odv->base_proc_symtree == NULL && search_ns != ns)
|
||||
|| (odv->base_proc_symtree != NULL
|
||||
&& strcmp (odv->base_proc_symtree->name, ns->proc_name->name)))
|
||||
&& !ns->proc_name->attr.use_assoc
|
||||
&& strcmp (odv->base_proc_symtree->name, ns->proc_name->name))
|
||||
|| (odv->base_proc_symtree != NULL
|
||||
&& ns->proc_name->attr.use_assoc
|
||||
&& strcmp (odv->base_proc_symtree->n.sym->name,
|
||||
ns->proc_name->name)))
|
||||
continue;
|
||||
|
||||
tree set_selectors = gfc_trans_omp_set_selector (odv->set_selectors,
|
||||
|
|
|
|||
|
|
@ -70,7 +70,7 @@ tree gfc_trans_deallocate (gfc_code *);
|
|||
/* trans-openmp.cc */
|
||||
tree gfc_trans_omp_directive (gfc_code *);
|
||||
void gfc_trans_omp_declare_simd (gfc_namespace *);
|
||||
void gfc_trans_omp_declare_variant (gfc_namespace *);
|
||||
void gfc_trans_omp_declare_variant (gfc_namespace *, gfc_namespace *);
|
||||
tree gfc_trans_omp_metadirective (gfc_code *code);
|
||||
tree gfc_trans_oacc_directive (gfc_code *);
|
||||
tree gfc_trans_oacc_declare (gfc_namespace *);
|
||||
|
|
|
|||
81
gcc/testsuite/gfortran.dg/gomp/declare-variant-mod-1-use.f90
Normal file
81
gcc/testsuite/gfortran.dg/gomp/declare-variant-mod-1-use.f90
Normal file
|
|
@ -0,0 +1,81 @@
|
|||
! { dg-do compile { target skip-all-targets } }
|
||||
! used by declare-variant-mod-1.f90
|
||||
|
||||
! Check that module-file handling works for declare_variant
|
||||
! and its match/adjust_args/append_args clauses
|
||||
!
|
||||
! PR fortran/115271
|
||||
|
||||
subroutine test1
|
||||
use m1
|
||||
use iso_c_binding, only: c_loc, c_ptr
|
||||
implicit none (type, external)
|
||||
|
||||
integer :: i, j
|
||||
type(c_ptr) :: a1, b1, c1, x1, y1, z1
|
||||
|
||||
!$omp dispatch
|
||||
i = m1_g (a1, b1, c1)
|
||||
j = m1_g (x1, y1, z1)
|
||||
end
|
||||
! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ = __builtin_omp_get_mapped_ptr \\(c1.\[0-9\]+, D\\.\[0-9\]+\\);" 1 "gimplify" } }
|
||||
! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ = __builtin_omp_get_mapped_ptr \\(a1, D\\.\[0-9\]+\\);" 1 "gimplify" } }
|
||||
! { dg-final { scan-tree-dump-times "i = m1_f \\(D\\.\[0-9\]+, &b1, &D\\.\[0-9\]+\\);" 1 "gimplify" } }
|
||||
! { dg-final { scan-tree-dump-times "j = m1_g \\(x1, &y1, &z1\\);" 1 "gimplify" } }
|
||||
|
||||
subroutine test2
|
||||
use m2, only: m2_g
|
||||
use iso_c_binding, only: c_loc, c_ptr
|
||||
implicit none (type, external)
|
||||
|
||||
integer :: i, j
|
||||
type(c_ptr) :: a2, b2, c2, x2, y2, z2
|
||||
|
||||
!$omp dispatch
|
||||
i = m2_g (a2, b2, c2)
|
||||
j = m2_g (x2, y2, z2)
|
||||
end
|
||||
! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ = __builtin_omp_get_mapped_ptr (c2.\[0-9\]+, D\\.\[0-9\]+);" 1 "gimplify" } }
|
||||
! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ = __builtin_omp_get_mapped_ptr (a2, D\\.\[0-9\]+);" 1 "gimplify" } }
|
||||
! { dg-final { scan-tree-dump-times "i = m2_f (D\\.\[0-9\]+, &b2, &D\\.\[0-9\]+);" 1 "gimplify" } }
|
||||
! { dg-final { scan-tree-dump-times "j = m2_g \\(x2, &y2, &z2\\);" 1 "gimplify" } }
|
||||
|
||||
subroutine test3
|
||||
use m2, only: my_func => m2_g
|
||||
use iso_c_binding, only: c_loc, c_ptr
|
||||
implicit none (type, external)
|
||||
|
||||
integer :: i, j
|
||||
type(c_ptr) :: a3, b3, c3, x3, y3, z3
|
||||
|
||||
!$omp dispatch
|
||||
i = my_func (a3, b3, c3)
|
||||
j = my_func (x3, y3, z3)
|
||||
end
|
||||
! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ = __builtin_omp_get_mapped_ptr (c3.\[0-9\]+, D\\.\[0-9\]+);" 1 "gimplify" } }
|
||||
! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ = __builtin_omp_get_mapped_ptr (a3, D\\.\[0-9\]+);" 1 "gimplify" } }
|
||||
! { dg-final { scan-tree-dump-times "i = m2_f (D\\.\[0-9\]+, &b3, &D\\.\[0-9\]+);" 1 "gimplify" } }
|
||||
! { dg-final { scan-tree-dump-times "j = m2_g \\(x3, &y3, &z3\\);" 1 "gimplify" } }
|
||||
|
||||
subroutine test4
|
||||
use m3, only: my_m3_g
|
||||
use iso_c_binding, only: c_loc, c_ptr
|
||||
implicit none (type, external)
|
||||
|
||||
integer :: i, j
|
||||
type(c_ptr) :: a4, b4, c4, x4, y4, z4
|
||||
|
||||
!$omp dispatch
|
||||
i = my_m3_g (a4, b4, c4)
|
||||
j = my_m3_g (x4, y4, z4)
|
||||
end
|
||||
! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ = __builtin_omp_get_mapped_ptr (c4.\[0-9\]+, D\\.\[0-9\]+);" 1 "gimplify" } }
|
||||
! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ = __builtin_omp_get_mapped_ptr (a4, D\\.\[0-9\]+);" 1 "gimplify" } }
|
||||
! { dg-final { scan-tree-dump-times "i = m3_f (D\\.\[0-9\]+, &b4, &D\\.\[0-9\]+);" 1 "gimplify" } }
|
||||
! { dg-final { scan-tree-dump-times "j = m3_g \\(x4, &y4, &z4\\);" 1 "gimplify" } }
|
||||
|
||||
program main
|
||||
call test1
|
||||
call test2
|
||||
call test3
|
||||
end
|
||||
83
gcc/testsuite/gfortran.dg/gomp/declare-variant-mod-1.f90
Normal file
83
gcc/testsuite/gfortran.dg/gomp/declare-variant-mod-1.f90
Normal file
|
|
@ -0,0 +1,83 @@
|
|||
! { dg-do link }
|
||||
! { dg-additional-options "-fdump-tree-gimple" }
|
||||
! { dg-additional-sources "declare-variant-mod-1-use.f90" }
|
||||
|
||||
! Note: We have to use 'link' as otherwise '-o' is specified,
|
||||
! which does not work with multiple files.
|
||||
|
||||
! Check that module-file handling works for declare_variant
|
||||
! and its match/adjust_args/append_args clauses
|
||||
!
|
||||
! PR fortran/115271
|
||||
|
||||
! Define to make linker happy
|
||||
integer function m1_f (x, y, z)
|
||||
use iso_c_binding
|
||||
type(c_ptr) :: x, y, z
|
||||
value :: x
|
||||
end
|
||||
|
||||
integer function m1_g (x, y, z)
|
||||
use iso_c_binding
|
||||
type(c_ptr) :: x, y, z
|
||||
value :: x
|
||||
end
|
||||
|
||||
module m1
|
||||
implicit none (type, external)
|
||||
|
||||
interface
|
||||
integer function m1_f (x, y, z)
|
||||
use iso_c_binding
|
||||
type(c_ptr) :: x, y, z
|
||||
value :: x
|
||||
end
|
||||
integer function m1_g (x, y, z)
|
||||
!$omp declare variant(m1_f) match(construct={dispatch}) adjust_args(need_device_ptr: x, 3) adjust_args(nothing: y)
|
||||
use iso_c_binding
|
||||
type(c_ptr) :: x, y, z
|
||||
value :: x
|
||||
end
|
||||
end interface
|
||||
end module m1
|
||||
|
||||
module m2
|
||||
implicit none (type, external)
|
||||
contains
|
||||
integer function m2_f (x, y, z)
|
||||
use iso_c_binding
|
||||
type(c_ptr) :: x, y, z
|
||||
value :: x
|
||||
m2_f = 1
|
||||
end
|
||||
integer function m2_g (x, y, z)
|
||||
!$omp declare variant(m2_f) match(construct={dispatch}) adjust_args(need_device_ptr: x, 3) adjust_args(nothing: y)
|
||||
use iso_c_binding
|
||||
type(c_ptr) :: x, y, z
|
||||
value :: x
|
||||
m2_g = 2
|
||||
end
|
||||
end module m2
|
||||
|
||||
module m3_pre
|
||||
implicit none (type, external)
|
||||
contains
|
||||
integer function m3_f (x, y, z)
|
||||
use iso_c_binding
|
||||
type(c_ptr) :: x, y, z
|
||||
value :: x
|
||||
m3_f = 1
|
||||
end
|
||||
integer function m3_g (x, y, z)
|
||||
use iso_c_binding
|
||||
type(c_ptr) :: x, y, z
|
||||
value :: x
|
||||
m3_g = 2
|
||||
end
|
||||
end module m3_pre
|
||||
|
||||
module m3
|
||||
use m3_pre, only: my_m3_f => m3_f, my_m3_g => m3_g
|
||||
implicit none (type, external)
|
||||
!$omp declare variant(my_m3_g : my_m3_f) match(construct={dispatch}) adjust_args(need_device_ptr: 1, 3) adjust_args(nothing: 2)
|
||||
end module m3
|
||||
47
gcc/testsuite/gfortran.dg/gomp/declare-variant-mod-2-use.f90
Normal file
47
gcc/testsuite/gfortran.dg/gomp/declare-variant-mod-2-use.f90
Normal file
|
|
@ -0,0 +1,47 @@
|
|||
! { dg-do compile { target skip-all-targets } }
|
||||
! used by declare-variant-mod-2.f90
|
||||
|
||||
! Check that module-file handling works for declare_variant
|
||||
! and its match/adjust_args/append_args clauses
|
||||
!
|
||||
! PR fortran/115271
|
||||
|
||||
! THIS FILE PROCUEDES ERROR - SEE declare-variant-mod-2.f90 for dg-error lines
|
||||
|
||||
module m_test1
|
||||
use m1, only: my_m1_f => m1_f, my_m1_g => m1_g
|
||||
!$omp declare variant(my_m1_g : my_m1_f) match(construct={dispatch}) adjust_args(need_device_ptr: 1, 3) adjust_args(nothing: 1)
|
||||
end
|
||||
|
||||
subroutine test1 ! See PR fortran/119288 - related to the following 'adjust_args' diagnostic
|
||||
use m_test1 ! { dg-error "'x' at .1. is specified more than once" }
|
||||
use iso_c_binding, only: c_ptr
|
||||
implicit none (type, external)
|
||||
type(c_ptr) :: a1,b1,c1
|
||||
integer :: i
|
||||
!$omp dispatch
|
||||
i = my_m1_g(a1,b1,c1)
|
||||
end
|
||||
|
||||
subroutine test2
|
||||
use m2
|
||||
implicit none (type, external)
|
||||
integer :: i, t2_a1, t2_a2, t2_a3, t2_a4
|
||||
|
||||
call m2_g(t2_a1)
|
||||
|
||||
!$omp dispatch
|
||||
call m2_g(t2_a2)
|
||||
|
||||
!$omp parallel if(.false.)
|
||||
!$omp dispatch
|
||||
call m2_g(t2_a3)
|
||||
!$omp end parallel
|
||||
|
||||
!$omp do
|
||||
do i = 1, 1
|
||||
!$omp dispatch
|
||||
call m2_g(t2_a4)
|
||||
end do
|
||||
|
||||
end
|
||||
74
gcc/testsuite/gfortran.dg/gomp/declare-variant-mod-2.f90
Normal file
74
gcc/testsuite/gfortran.dg/gomp/declare-variant-mod-2.f90
Normal file
|
|
@ -0,0 +1,74 @@
|
|||
! { dg-do link }
|
||||
! { dg-additional-options "-fdump-tree-gimple" }
|
||||
! { dg-additional-sources "declare-variant-mod-2-use.f90" }
|
||||
|
||||
! Note: We have to use 'link' as otherwise '-o' is specified,
|
||||
! which does not work with multiple files.
|
||||
|
||||
! Error message in the additional-sources file:
|
||||
|
||||
! { dg-error "'x' at .1. is specified more than once" "" { target *-*-* } 17 }
|
||||
|
||||
! { dg-message "sorry, unimplemented: 'append_args' clause not yet supported for 'm2_f1', except when specifying all 1 objects in the 'interop' clause of the 'dispatch' directive" "" { target *-*-* } 27 }
|
||||
! { dg-note "required by 'dispatch' construct" "" { target *-*-* } 33 }
|
||||
! { dg-message "sorry, unimplemented: 'append_args' clause not yet supported for 'm2_f2', except when specifying all 2 objects in the 'interop' clause of the 'dispatch' directive" "" { target *-*-* } 27 }
|
||||
! { dg-note "required by 'dispatch' construct" "" { target *-*-* } 37 }
|
||||
! { dg-message "sorry, unimplemented: 'append_args' clause not yet supported for 'm2_f3', except when specifying all 3 objects in the 'interop' clause of the 'dispatch' directive" "" { target *-*-* } 27 }
|
||||
! { dg-note "required by 'dispatch' construct" "" { target *-*-* } 43 }
|
||||
|
||||
! Check that module-file handling works for declare_variant
|
||||
! and its match/adjust_args/append_args clauses
|
||||
!
|
||||
! PR fortran/115271
|
||||
|
||||
module m1
|
||||
implicit none (type, external)
|
||||
contains
|
||||
integer function m1_f (x, y, z)
|
||||
use iso_c_binding
|
||||
type(c_ptr) :: x, y, z
|
||||
value :: x
|
||||
m1_f = 1
|
||||
end
|
||||
integer function m1_g (x, y, z)
|
||||
use iso_c_binding
|
||||
type(c_ptr) :: x, y, z
|
||||
value :: x
|
||||
m1_g = 2
|
||||
end
|
||||
end module m1
|
||||
|
||||
module m2
|
||||
use iso_c_binding, only: c_intptr_t
|
||||
implicit none (type, external)
|
||||
integer, parameter :: omp_interop_kind = c_intptr_t
|
||||
|
||||
!$omp declare variant(m2_g : m2_f3) match(construct={do,dispatch}, device={kind(host)}) &
|
||||
!$omp& append_args(interop(target),interop(targetsync), interop(prefer_type({fr("cuda"), attr("ompx_A")}, {fr("hip")}, {attr("ompx_B")}), targetsync))
|
||||
|
||||
contains
|
||||
subroutine m2_f3 (x, obj1, obj2, obj3)
|
||||
use iso_c_binding
|
||||
integer(omp_interop_kind) :: obj1, obj2, obj3
|
||||
value :: obj1
|
||||
integer, value :: x
|
||||
end
|
||||
|
||||
subroutine m2_f2 (x, obj1, obj2)
|
||||
use iso_c_binding
|
||||
integer(omp_interop_kind) :: obj1, obj2
|
||||
integer, value :: x
|
||||
end
|
||||
|
||||
subroutine m2_f1 (x, obj1)
|
||||
use iso_c_binding
|
||||
integer(omp_interop_kind), value :: obj1
|
||||
integer, value :: x
|
||||
end
|
||||
|
||||
subroutine m2_g (x)
|
||||
integer, value :: x
|
||||
!$omp declare variant(m2_g : m2_f1) match(construct={dispatch}) append_args(interop(target, targetsync, prefer_type("cuda", "hip")))
|
||||
!$omp declare variant(m2_f2) match(construct={parallel,dispatch}, implementation={vendor("gnu")}) append_args(interop(target),interop(targetsync))
|
||||
end
|
||||
end module
|
||||
Loading…
Add table
Reference in a new issue