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_declare_simd *ods = *odsp;
+ gfc_omp_clauses *clauses = *clausesp;
+ gfc_omp_namelist *n;
- 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
{
+ 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;
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:
}
}
}
+}
+
+
+/* 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[] =
{
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 ();
}
--- /dev/null
+! { 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
--- /dev/null
+! { 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
projects / thirdparty / gcc.git / commitdiff
