Fortran: Add 'device_type' clause to OpenMP's declare target
gcc/fortran/ChangeLog:
* gfortran.h (enum gfc_omp_device_type): New.
(symbol_attribute, gfc_omp_clauses, gfc_common_head): Use it.
* module.c (enum ab_attribute): Add AB_OMP_DEVICE_TYPE_HOST,
AB_OMP_DEVICE_TYPE_NOHOST and AB_OMP_DEVICE_TYPE_ANY.
(attr_bits, mio_symbol_attribute): Handle it.
(load_commons, write_common_0): Handle omp_device_type flag.
* openmp.c (enum omp_mask1): Add OMP_CLAUSE_DEVICE_TYPE
(OMP_DECLARE_TARGET_CLAUSES): Likewise.
(gfc_match_omp_clauses): Match 'device_type'.
(gfc_match_omp_declare_target): Handle it.
* trans-common.c (build_common_decl): Write device-type clause.
* trans-decl.c (add_attributes_to_decl): Likewise.
gcc/testsuite/ChangeLog:
* gfortran.dg/gomp/declare-target-4.f90: New test.
* gfortran.dg/gomp/declare-target-5.f90: New test.
gcc/fortran/gfortran.h | 10 +++
gcc/fortran/module.c | 33 ++++++++-
gcc/fortran/openmp.c | 50 ++++++++++++-
gcc/fortran/trans-common.c | 25 ++++++-
gcc/fortran/trans-decl.c | 22 +++++-
.../gfortran.dg/gomp/declare-target-4.f90 | 81 ++++++++++++++++++++++
.../gfortran.dg/gomp/declare-target-5.f90 | 33 +++++++++
7 files changed, 247 insertions(+), 7 deletions(-)
@@ -753,6 +753,13 @@ CInteropKind_t;
that the list is initialized. */
extern CInteropKind_t c_interop_kinds_table[];
+enum gfc_omp_device_type
+{
+ OMP_DEVICE_TYPE_UNSET,
+ OMP_DEVICE_TYPE_HOST,
+ OMP_DEVICE_TYPE_NOHOST,
+ OMP_DEVICE_TYPE_ANY
+};
/* Structure and list of supported extension attributes. */
typedef enum
@@ -919,6 +926,7 @@ typedef struct
/* Mentioned in OMP DECLARE TARGET. */
unsigned omp_declare_target:1;
unsigned omp_declare_target_link:1;
+ ENUM_BITFIELD (gfc_omp_device_type) omp_device_type:2;
/* Mentioned in OACC DECLARE. */
unsigned oacc_declare_create:1;
@@ -1359,6 +1367,7 @@ typedef struct gfc_omp_clauses
struct gfc_expr *num_threads;
gfc_omp_namelist *lists[OMP_LIST_NUM];
enum gfc_omp_sched_kind sched_kind;
+ enum gfc_omp_device_type device_type;
struct gfc_expr *chunk_size;
enum gfc_omp_default_sharing default_sharing;
int collapse, orderedc;
@@ -1698,6 +1707,7 @@ typedef struct gfc_common_head
char use_assoc, saved, threadprivate;
unsigned char omp_declare_target : 1;
unsigned char omp_declare_target_link : 1;
+ ENUM_BITFIELD (gfc_omp_device_type) omp_device_type:2;
/* Provide sufficient space to hold "symbol.symbol.eq.1234567890". */
char name[2*GFC_MAX_SYMBOL_LEN + 1 + 14 + 1];
struct gfc_symbol *head;
@@ -2051,7 +2051,8 @@ enum ab_attribute
AB_OMP_REQ_REVERSE_OFFLOAD, AB_OMP_REQ_UNIFIED_ADDRESS,
AB_OMP_REQ_UNIFIED_SHARED_MEMORY, AB_OMP_REQ_DYNAMIC_ALLOCATORS,
AB_OMP_REQ_MEM_ORDER_SEQ_CST, AB_OMP_REQ_MEM_ORDER_ACQ_REL,
- AB_OMP_REQ_MEM_ORDER_RELAXED
+ AB_OMP_REQ_MEM_ORDER_RELAXED, AB_OMP_DEVICE_TYPE_NOHOST,
+ AB_OMP_DEVICE_TYPE_HOST, AB_OMP_DEVICE_TYPE_ANY
};
static const mstring attr_bits[] =
@@ -2132,6 +2133,9 @@ static const mstring attr_bits[] =
minit ("OMP_REQ_MEM_ORDER_SEQ_CST", AB_OMP_REQ_MEM_ORDER_SEQ_CST),
minit ("OMP_REQ_MEM_ORDER_ACQ_REL", AB_OMP_REQ_MEM_ORDER_ACQ_REL),
minit ("OMP_REQ_MEM_ORDER_RELAXED", AB_OMP_REQ_MEM_ORDER_RELAXED),
+ minit ("OMP_DEVICE_TYPE_HOST", AB_OMP_DEVICE_TYPE_HOST),
+ minit ("OMP_DEVICE_TYPE_NOHOST", AB_OMP_DEVICE_TYPE_NOHOST),
+ minit ("OMP_DEVICE_TYPE_ANYHOST", AB_OMP_DEVICE_TYPE_ANY),
minit (NULL, -1)
};
@@ -2397,6 +2401,22 @@ mio_symbol_attribute (symbol_attribute *attr)
== OMP_REQ_ATOMIC_MEM_ORDER_RELAXED)
MIO_NAME (ab_attribute) (AB_OMP_REQ_MEM_ORDER_RELAXED, attr_bits);
}
+ switch (attr->omp_device_type)
+ {
+ case OMP_DEVICE_TYPE_UNSET:
+ break;
+ case OMP_DEVICE_TYPE_HOST:
+ MIO_NAME (ab_attribute) (AB_OMP_DEVICE_TYPE_NOHOST, attr_bits);
+ break;
+ case OMP_DEVICE_TYPE_NOHOST:
+ MIO_NAME (ab_attribute) (AB_OMP_DEVICE_TYPE_NOHOST, attr_bits);
+ break;
+ case OMP_DEVICE_TYPE_ANY:
+ MIO_NAME (ab_attribute) (AB_OMP_DEVICE_TYPE_ANY, attr_bits);
+ break;
+ default:
+ gcc_unreachable ();
+ }
mio_rparen ();
}
else
@@ -2661,6 +2681,15 @@ mio_symbol_attribute (symbol_attribute *attr)
"relaxed", &gfc_current_locus,
module_name);
break;
+ case AB_OMP_DEVICE_TYPE_HOST:
+ attr->omp_device_type = OMP_DEVICE_TYPE_HOST;
+ break;
+ case AB_OMP_DEVICE_TYPE_NOHOST:
+ attr->omp_device_type = OMP_DEVICE_TYPE_NOHOST;
+ break;
+ case AB_OMP_DEVICE_TYPE_ANY:
+ attr->omp_device_type = OMP_DEVICE_TYPE_ANY;
+ break;
}
}
}
@@ -4849,6 +4878,7 @@ load_commons (void)
p->saved = 1;
if (flags & 2)
p->threadprivate = 1;
+ p->omp_device_type = (gfc_omp_device_type) ((flags >> 2) & 3);
p->use_assoc = 1;
/* Get whether this was a bind(c) common or not. */
@@ -5713,6 +5743,7 @@ write_common_0 (gfc_symtree *st, bool this_module)
flags = p->saved ? 1 : 0;
if (p->threadprivate)
flags |= 2;
+ flags |= p->omp_device_type << 2;
mio_integer (&flags);
/* Write out whether the common block is bind(c) or not. */
@@ -752,7 +752,7 @@ cleanup:
return MATCH_ERROR;
}
-/* OpenMP 4.5 clauses. */
+/* OpenMP clauses. */
enum omp_mask1
{
OMP_CLAUSE_PRIVATE,
@@ -799,7 +799,8 @@ enum omp_mask1
OMP_CLAUSE_SIMD,
OMP_CLAUSE_THREADS,
OMP_CLAUSE_USE_DEVICE_PTR,
- OMP_CLAUSE_USE_DEVICE_ADDR, /* Actually, OpenMP 5.0. */
+ OMP_CLAUSE_USE_DEVICE_ADDR, /* OpenMP 5.0. */
+ OMP_CLAUSE_DEVICE_TYPE, /* OpenMP 5.0. */
OMP_CLAUSE_NOWAIT,
/* This must come last. */
OMP_MASK1_LAST
@@ -1213,6 +1214,24 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
OMP_MAP_FORCE_DEVICEPTR, false,
allow_derived))
continue;
+ if ((mask & OMP_CLAUSE_DEVICE_TYPE)
+ && gfc_match ("device_type ( ") == MATCH_YES)
+ {
+ if (gfc_match ("host") == MATCH_YES)
+ c->device_type = OMP_DEVICE_TYPE_HOST;
+ else if (gfc_match ("nohost") == MATCH_YES)
+ c->device_type = OMP_DEVICE_TYPE_NOHOST;
+ else if (gfc_match ("any") == MATCH_YES)
+ c->device_type = OMP_DEVICE_TYPE_ANY;
+ else
+ {
+ gfc_error ("Expected HOST, NOHOST or ANY at %C");
+ break;
+ }
+ if (gfc_match (" )") != MATCH_YES)
+ break;
+ continue;
+ }
if ((mask & OMP_CLAUSE_DEVICE_RESIDENT)
&& gfc_match_omp_variable_list
("device_resident (",
@@ -2632,7 +2651,7 @@ cleanup:
#define OMP_ORDERED_CLAUSES \
(omp_mask (OMP_CLAUSE_THREADS) | OMP_CLAUSE_SIMD)
#define OMP_DECLARE_TARGET_CLAUSES \
- (omp_mask (OMP_CLAUSE_TO) | OMP_CLAUSE_LINK)
+ (omp_mask (OMP_CLAUSE_TO) | OMP_CLAUSE_LINK | OMP_CLAUSE_DEVICE_TYPE)
static match
@@ -3269,6 +3288,15 @@ gfc_match_omp_declare_target (void)
gfc_add_omp_declare_target_link (&n->sym->attr, n->sym->name,
&n->sym->declared_at);
}
+ if (c->device_type != OMP_DEVICE_TYPE_UNSET)
+ {
+ if (n->sym->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
+ && n->sym->attr.omp_device_type != c->device_type)
+ gfc_error_now ("List item %qs at %L set in previous OMP DECLARE "
+ "TARGET directive to a different DEVICE_TYPE",
+ n->sym->name, &n->where);
+ n->sym->attr.omp_device_type = c->device_type;
+ }
n->sym->mark = 1;
}
else if (n->u.common->omp_declare_target
@@ -3291,6 +3319,13 @@ gfc_match_omp_declare_target (void)
{
n->u.common->omp_declare_target = 1;
n->u.common->omp_declare_target_link = (list == OMP_LIST_LINK);
+ if (n->u.common->omp_device_type != OMP_DEVICE_TYPE_UNSET
+ && n->u.common->omp_device_type != c->device_type)
+ gfc_error_now ("COMMON at %L set in previous OMP DECLARE "
+ "TARGET directive to a different DEVICE_TYPE",
+ &n->where);
+ n->u.common->omp_device_type = c->device_type;
+
for (s = n->u.common->head; s; s = s->common_next)
{
s->mark = 1;
@@ -3301,8 +3336,17 @@ gfc_match_omp_declare_target (void)
gfc_add_omp_declare_target_link (&s->attr, s->name,
&s->declared_at);
}
+ if (s->attr.omp_device_type != OMP_DEVICE_TYPE_UNSET
+ && s->attr.omp_device_type != c->device_type)
+ gfc_error_now ("List item %qs at %L set in previous OMP DECLARE"
+ " TARGET directive to a different DEVICE_TYPE",
+ s->name, &n->where);
+ s->attr.omp_device_type = c->device_type;
}
}
+ if (c->device_type && !c->lists[OMP_LIST_TO] && !c->lists[OMP_LIST_LINK])
+ gfc_warning_now (0, "OMP DECLARE TARGET directive at %L with only "
+ "DEVICE_TYPE clause is ignored", &old_loc);
gfc_buffer_error (true);
@@ -426,6 +426,8 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
/* If there is no backend_decl for the common block, build it. */
if (decl == NULL_TREE)
{
+ tree clauses = NULL_TREE;
+
if (com->is_bind_c == 1 && com->binding_label)
decl = build_decl (input_location, VAR_DECL, identifier, union_type);
else
@@ -460,14 +462,33 @@ build_common_decl (gfc_common_head *com, tree union_type, bool is_init)
if (com->threadprivate)
set_decl_tls_model (decl, decl_default_tls_model (decl));
+ if (com->omp_device_type != OMP_DEVICE_TYPE_UNSET)
+ {
+ tree c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_DEVICE_TYPE);
+ switch (com->omp_device_type)
+ {
+ case OMP_DEVICE_TYPE_HOST:
+ OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_HOST;
+ break;
+ case OMP_DEVICE_TYPE_NOHOST:
+ OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_NOHOST;
+ break;
+ case OMP_DEVICE_TYPE_ANY:
+ OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_ANY;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ clauses = c;
+ }
if (com->omp_declare_target_link)
DECL_ATTRIBUTES (decl)
= tree_cons (get_identifier ("omp declare target link"),
- NULL_TREE, DECL_ATTRIBUTES (decl));
+ clauses, DECL_ATTRIBUTES (decl));
else if (com->omp_declare_target)
DECL_ATTRIBUTES (decl)
= tree_cons (get_identifier ("omp declare target"),
- NULL_TREE, DECL_ATTRIBUTES (decl));
+ clauses, DECL_ATTRIBUTES (decl));
/* Place the back end declaration for this common block in
GLOBAL_BINDING_LEVEL. */
@@ -1465,11 +1465,31 @@ add_attributes_to_decl (symbol_attribute sym_attr, tree list)
tree dims = oacc_build_routine_dims (clauses);
list = oacc_replace_fn_attrib_attr (list, dims);
}
+ if (sym_attr.omp_device_type != OMP_DEVICE_TYPE_UNSET)
+ {
+ tree c = build_omp_clause (UNKNOWN_LOCATION, OMP_CLAUSE_DEVICE_TYPE);
+ switch (sym_attr.omp_device_type)
+ {
+ case OMP_DEVICE_TYPE_HOST:
+ OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_HOST;
+ break;
+ case OMP_DEVICE_TYPE_NOHOST:
+ OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_NOHOST;
+ break;
+ case OMP_DEVICE_TYPE_ANY:
+ OMP_CLAUSE_DEVICE_TYPE_KIND (c) = OMP_CLAUSE_DEVICE_TYPE_ANY;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ OMP_CLAUSE_CHAIN (c) = clauses;
+ clauses = c;
+ }
if (sym_attr.omp_declare_target_link
|| sym_attr.oacc_declare_link)
list = tree_cons (get_identifier ("omp declare target link"),
- NULL_TREE, list);
+ clauses, list);
else if (sym_attr.omp_declare_target
|| sym_attr.oacc_declare_create
|| sym_attr.oacc_declare_copyin
new file mode 100644
@@ -0,0 +1,81 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-original" }
+
+subroutine f1
+ !$omp declare target device_type (any) ! { dg-warning "OMP DECLARE TARGET directive at .1. with only DEVICE_TYPE clause is ignored" }
+end subroutine
+
+subroutine f2
+ !$omp declare target to (f2) device_type (any)
+end subroutine
+
+subroutine f3
+ !$omp declare target device_type (any) to (f3)
+end subroutine
+
+subroutine f4
+ !$omp declare target device_type (host) to (f4)
+end subroutine
+
+subroutine f5
+ !$omp declare target device_type (nohost) to (f5)
+end subroutine
+
+module mymod
+ ! device_type is ignored for variables in OpenMP 5.0
+ ! but TR8 and later apply those rules to variables as well
+ implicit none
+ integer :: a, b(4), c, d
+ integer :: e, f, g
+ integer :: m, n, o, p, q, r, s, t, u, v, w, x
+ common /block1/ m, n
+ common /block2/ o, p
+ common /block3/ q, r
+ common /block4/ s, t
+ common /block5/ u, v
+ common /block6/ w, x
+
+ !$omp declare target to(a) device_type(nohost)
+ !$omp declare target to(b) device_type(host)
+ !$omp declare target to(c) device_type(any)
+ ! Fails in ME with "Error: wrong number of arguments specified for 'omp declare target link' attribute"
+ ! !$omp declare target link(e) device_type(nohost)
+ ! !$omp declare target link(f) device_type(host)
+ ! !$omp declare target link(g) device_type(any)
+
+ !$omp declare target to(/block1/) device_type(nohost)
+ !$omp declare target to(/block2/) device_type(host)
+ !$omp declare target to(/block3/) device_type(any)
+ !$omp declare target link(/block4/) device_type(nohost)
+ !$omp declare target link(/block5/) device_type(host)
+ !$omp declare target link(/block6/) device_type(any)
+contains
+ subroutine s1
+ !$omp declare target to (s1) device_type (any)
+ end
+ subroutine s2
+ !$omp declare target to (s2) device_type (nohost)
+ end
+ subroutine s3
+ !$omp declare target to (s3) device_type (host)
+ end
+end module
+
+module m2
+ use mymod
+ implicit none
+ public
+ private :: s1, s2, s3, a, b, c, d, e, f, g
+ public :: m, n, o, p, q, r, s, t, u, v, w, x
+end module m2
+
+! { dg-final { scan-tree-dump-times "omp declare target" 7 "original" } }
+! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare target \\(device_type\\(" 7 "original" } }
+! { dg-final { scan-tree-dump-times "\[\n\r]\[\n\r]f1" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare target \\(device_type\\(any\\)\\)\\)\\)\[\n\r]f2" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare target \\(device_type\\(any\\)\\)\\)\\)\[\n\r]f3" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare target \\(device_type\\(host\\)\\)\\)\\)\[\n\r]f4" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare target \\(device_type\\(nohost\\)\\)\\)\\)\[\n\r]f5" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare target \\(device_type\\(any\\)\\)\\)\\)\[\n\r]s1" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare target \\(device_type\\(nohost\\)\\)\\)\\)\[\n\r]s2" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__attribute__\\(\\(omp declare target \\(device_type\\(host\\)\\)\\)\\)\[\n\r]s3" 1 "original" } }
new file mode 100644
@@ -0,0 +1,33 @@
+subroutine foo()
+ !$omp declare target to(foo) device_type(bar) ! { dg-error "Expected HOST, NOHOST or ANY" }
+end
+
+subroutine bar()
+ !$omp declare target to(bar) device_type(nohost)
+ !$omp declare target to(bar) device_type(host) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" }
+end
+
+module mymod
+ implicit none
+ integer :: a, b, c, d, e ,f
+ integer :: m, n, o, p, q, r
+ common /block1/ m, n
+ common /block2/ o, p
+ common /block3/ q, r
+ !$omp declare target to(a) device_type(nohost)
+ !$omp declare target to(b) device_type(any)
+ !$omp declare target to(c) device_type(host)
+ !$omp declare target link(d) device_type(nohost)
+ !$omp declare target link(e) device_type(any)
+ !$omp declare target link(f) device_type(host)
+
+ !$omp declare target to(c) device_type(host)
+ !$omp declare target link(d) device_type(nohost)
+
+ !$omp declare target to(a) device_type(any) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" }
+ !$omp declare target to(b) device_type(host) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" }
+ !$omp declare target to(c) device_type(nohost) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" }
+ !$omp declare target link(d) device_type(host) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" }
+ !$omp declare target link(e) device_type(nohost) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" }
+ !$omp declare target link(f) device_type(any) ! { dg-error "previous OMP DECLARE TARGET directive to a different DEVICE_TYPE" }
+end