public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r12-4409] openmp, fortran: Add support for OpenMP declare variant directive in Fortran
@ 2021-10-14 16:19 Kwok Yeung
0 siblings, 0 replies; only message in thread
From: Kwok Yeung @ 2021-10-14 16:19 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:724ee5a0093da443563ae98ec5cb76164c36be80
commit r12-4409-g724ee5a0093da443563ae98ec5cb76164c36be80
Author: Kwok Cheung Yeung <kcy@codesourcery.com>
Date: Thu Oct 14 07:57:12 2021 -0700
openmp, fortran: Add support for OpenMP declare variant directive in Fortran
2021-10-14 Kwok Cheung Yeung <kcy@codesourcery.com>
gcc/c-family/
* c-omp.c (c_omp_check_context_selector): Rename to
omp_check_context_selector and move to omp-general.c.
(c_omp_mark_declare_variant): Rename to omp_mark_declare_variant and
move to omp-general.c.
gcc/c/
* c-parser.c (c_finish_omp_declare_variant): Change call from
c_omp_check_context_selector to omp_check_context_selector. Change
call from c_omp_mark_declare_variant to omp_mark_declare_variant.
gcc/cp/
* decl.c (omp_declare_variant_finalize_one): Change call from
c_omp_mark_declare_variant to omp_mark_declare_variant.
* parser.c (cp_finish_omp_declare_variant): Change call from
c_omp_check_context_selector to omp_check_context_selector.
gcc/fortran/
* gfortran.h (enum gfc_statement): Add ST_OMP_DECLARE_VARIANT.
(enum gfc_omp_trait_property_kind): New.
(struct gfc_omp_trait_property): New.
(gfc_get_omp_trait_property): New macro.
(struct gfc_omp_selector): New.
(gfc_get_omp_selector): New macro.
(struct gfc_omp_set_selector): New.
(gfc_get_omp_set_selector): New macro.
(struct gfc_omp_declare_variant): New.
(gfc_get_omp_declare_variant): New macro.
(struct gfc_namespace): Add omp_declare_variant field.
(gfc_free_omp_declare_variant_list): New prototype.
* match.h (gfc_match_omp_declare_variant): New prototype.
* openmp.c (gfc_free_omp_trait_property_list): New.
(gfc_free_omp_selector_list): New.
(gfc_free_omp_set_selector_list): New.
(gfc_free_omp_declare_variant_list): New.
(gfc_match_omp_clauses): Add extra optional argument. Handle end of
clauses for context selectors.
(omp_construct_selectors, omp_device_selectors,
omp_implementation_selectors, omp_user_selectors): New.
(gfc_match_omp_context_selector): New.
(gfc_match_omp_context_selector_specification): New.
(gfc_match_omp_declare_variant): New.
* parse.c: Include tree-core.h and omp-general.h.
(decode_omp_directive): Handle 'declare variant'.
(case_omp_decl): Include ST_OMP_DECLARE_VARIANT.
(gfc_ascii_statement): Handle ST_OMP_DECLARE_VARIANT.
(gfc_parse_file): Initialize omp_requires_mask.
* symbol.c (gfc_free_namespace): Call
gfc_free_omp_declare_variant_list.
* trans-decl.c (gfc_get_extern_function_decl): Call
gfc_trans_omp_declare_variant.
(gfc_create_function_decl): Call gfc_trans_omp_declare_variant.
* trans-openmp.c (gfc_trans_omp_declare_variant): New.
* trans-stmt.h (gfc_trans_omp_declare_variant): New prototype.
gcc/
* omp-general.c (omp_check_context_selector): Move from c-omp.c.
(omp_mark_declare_variant): Move from c-omp.c.
(omp_context_name_list_prop): Update for Fortran strings.
* omp-general.h (omp_check_context_selector): New prototype.
(omp_mark_declare_variant): New prototype.
gcc/testsuite/
* gfortran.dg/gomp/declare-variant-1.f90: New test.
* gfortran.dg/gomp/declare-variant-10.f90: New test.
* gfortran.dg/gomp/declare-variant-11.f90: New test.
* gfortran.dg/gomp/declare-variant-12.f90: New test.
* gfortran.dg/gomp/declare-variant-13.f90: New test.
* gfortran.dg/gomp/declare-variant-14.f90: New test.
* gfortran.dg/gomp/declare-variant-15.f90: New test.
* gfortran.dg/gomp/declare-variant-16.f90: New test.
* gfortran.dg/gomp/declare-variant-17.f90: New test.
* gfortran.dg/gomp/declare-variant-18.f90: New test.
* gfortran.dg/gomp/declare-variant-19.f90: New test.
* gfortran.dg/gomp/declare-variant-2.f90: New test.
* gfortran.dg/gomp/declare-variant-2a.f90: New test.
* gfortran.dg/gomp/declare-variant-3.f90: New test.
* gfortran.dg/gomp/declare-variant-4.f90: New test.
* gfortran.dg/gomp/declare-variant-5.f90: New test.
* gfortran.dg/gomp/declare-variant-6.f90: New test.
* gfortran.dg/gomp/declare-variant-7.f90: New test.
* gfortran.dg/gomp/declare-variant-8.f90: New test.
* gfortran.dg/gomp/declare-variant-9.f90: New test.
libgomp/
* testsuite/libgomp.fortran/declare-variant-1.f90: New test.
Diff:
---
gcc/c-family/c-omp.c | 137 ------
gcc/c/c-parser.c | 4 +-
gcc/cp/decl.c | 2 +-
gcc/cp/parser.c | 2 +-
gcc/fortran/gfortran.h | 73 ++-
gcc/fortran/match.h | 1 +
gcc/fortran/openmp.c | 513 ++++++++++++++++++++-
gcc/fortran/parse.c | 26 ++
gcc/fortran/symbol.c | 1 +
gcc/fortran/trans-decl.c | 16 +-
gcc/fortran/trans-openmp.c | 204 ++++++++
gcc/fortran/trans-stmt.h | 1 +
gcc/omp-general.c | 143 +++++-
gcc/omp-general.h | 3 +
.../gfortran.dg/gomp/declare-variant-1.f90 | 93 ++++
.../gfortran.dg/gomp/declare-variant-10.f90 | 97 ++++
.../gfortran.dg/gomp/declare-variant-11.f90 | 134 ++++++
.../gfortran.dg/gomp/declare-variant-12.f90 | 159 +++++++
.../gfortran.dg/gomp/declare-variant-13.f90 | 48 ++
.../gfortran.dg/gomp/declare-variant-14.f90 | 49 ++
.../gfortran.dg/gomp/declare-variant-15.f90 | 24 +
.../gfortran.dg/gomp/declare-variant-16.f90 | 24 +
.../gfortran.dg/gomp/declare-variant-17.f90 | 17 +
.../gfortran.dg/gomp/declare-variant-18.f90 | 17 +
.../gfortran.dg/gomp/declare-variant-19.f90 | 49 ++
.../gfortran.dg/gomp/declare-variant-2.f90 | 197 ++++++++
.../gfortran.dg/gomp/declare-variant-2a.f90 | 53 +++
.../gfortran.dg/gomp/declare-variant-3.f90 | 237 ++++++++++
.../gfortran.dg/gomp/declare-variant-4.f90 | 62 +++
.../gfortran.dg/gomp/declare-variant-5.f90 | 75 +++
.../gfortran.dg/gomp/declare-variant-6.f90 | 188 ++++++++
.../gfortran.dg/gomp/declare-variant-7.f90 | 93 ++++
.../gfortran.dg/gomp/declare-variant-8.f90 | 218 +++++++++
.../gfortran.dg/gomp/declare-variant-9.f90 | 58 +++
.../libgomp.fortran/declare-variant-1.f90 | 33 ++
35 files changed, 2903 insertions(+), 148 deletions(-)
diff --git a/gcc/c-family/c-omp.c b/gcc/c-family/c-omp.c
index b9024cb15a9..af9eba8d008 100644
--- a/gcc/c-family/c-omp.c
+++ b/gcc/c-family/c-omp.c
@@ -2911,143 +2911,6 @@ c_omp_predetermined_mapping (tree decl)
}
-/* Diagnose errors in an OpenMP context selector, return CTX if
- it is correct or error_mark_node otherwise. */
-
-tree
-c_omp_check_context_selector (location_t loc, tree ctx)
-{
- /* Each trait-set-selector-name can only be specified once.
- There are just 4 set names. */
- for (tree t1 = ctx; t1; t1 = TREE_CHAIN (t1))
- for (tree t2 = TREE_CHAIN (t1); t2; t2 = TREE_CHAIN (t2))
- if (TREE_PURPOSE (t1) == TREE_PURPOSE (t2))
- {
- error_at (loc, "selector set %qs specified more than once",
- IDENTIFIER_POINTER (TREE_PURPOSE (t1)));
- return error_mark_node;
- }
- for (tree t = ctx; t; t = TREE_CHAIN (t))
- {
- /* Each trait-selector-name can only be specified once. */
- if (list_length (TREE_VALUE (t)) < 5)
- {
- for (tree t1 = TREE_VALUE (t); t1; t1 = TREE_CHAIN (t1))
- for (tree t2 = TREE_CHAIN (t1); t2; t2 = TREE_CHAIN (t2))
- if (TREE_PURPOSE (t1) == TREE_PURPOSE (t2))
- {
- error_at (loc,
- "selector %qs specified more than once in set %qs",
- IDENTIFIER_POINTER (TREE_PURPOSE (t1)),
- IDENTIFIER_POINTER (TREE_PURPOSE (t)));
- return error_mark_node;
- }
- }
- else
- {
- hash_set<tree> pset;
- for (tree t1 = TREE_VALUE (t); t1; t1 = TREE_CHAIN (t1))
- if (pset.add (TREE_PURPOSE (t1)))
- {
- error_at (loc,
- "selector %qs specified more than once in set %qs",
- IDENTIFIER_POINTER (TREE_PURPOSE (t1)),
- IDENTIFIER_POINTER (TREE_PURPOSE (t)));
- return error_mark_node;
- }
- }
-
- static const char *const kind[] = {
- "host", "nohost", "cpu", "gpu", "fpga", "any", NULL };
- static const char *const vendor[] = {
- "amd", "arm", "bsc", "cray", "fujitsu", "gnu", "ibm", "intel",
- "llvm", "nvidia", "pgi", "ti", "unknown", NULL };
- static const char *const extension[] = { NULL };
- static const char *const atomic_default_mem_order[] = {
- "seq_cst", "relaxed", "acq_rel", NULL };
- struct known_properties { const char *set; const char *selector;
- const char *const *props; };
- known_properties props[] = {
- { "device", "kind", kind },
- { "implementation", "vendor", vendor },
- { "implementation", "extension", extension },
- { "implementation", "atomic_default_mem_order",
- atomic_default_mem_order } };
- for (tree t1 = TREE_VALUE (t); t1; t1 = TREE_CHAIN (t1))
- for (unsigned i = 0; i < ARRAY_SIZE (props); i++)
- if (!strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t1)),
- props[i].selector)
- && !strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)),
- props[i].set))
- for (tree t2 = TREE_VALUE (t1); t2; t2 = TREE_CHAIN (t2))
- for (unsigned j = 0; ; j++)
- {
- if (props[i].props[j] == NULL)
- {
- if (TREE_PURPOSE (t2)
- && !strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t2)),
- " score"))
- break;
- if (props[i].props == atomic_default_mem_order)
- {
- error_at (loc,
- "incorrect property %qs of %qs selector",
- IDENTIFIER_POINTER (TREE_PURPOSE (t2)),
- "atomic_default_mem_order");
- return error_mark_node;
- }
- else if (TREE_PURPOSE (t2))
- warning_at (loc, 0,
- "unknown property %qs of %qs selector",
- IDENTIFIER_POINTER (TREE_PURPOSE (t2)),
- props[i].selector);
- else
- warning_at (loc, 0,
- "unknown property %qE of %qs selector",
- TREE_VALUE (t2), props[i].selector);
- break;
- }
- else if (TREE_PURPOSE (t2) == NULL_TREE)
- {
- const char *str = TREE_STRING_POINTER (TREE_VALUE (t2));
- if (!strcmp (str, props[i].props[j])
- && ((size_t) TREE_STRING_LENGTH (TREE_VALUE (t2))
- == strlen (str) + 1))
- break;
- }
- else if (!strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t2)),
- props[i].props[j]))
- break;
- }
- }
- return ctx;
-}
-
-/* Register VARIANT as variant of some base function marked with
- #pragma omp declare variant. CONSTRUCT is corresponding construct
- selector set. */
-
-void
-c_omp_mark_declare_variant (location_t loc, tree variant, tree construct)
-{
- tree attr = lookup_attribute ("omp declare variant variant",
- DECL_ATTRIBUTES (variant));
- if (attr == NULL_TREE)
- {
- attr = tree_cons (get_identifier ("omp declare variant variant"),
- unshare_expr (construct),
- DECL_ATTRIBUTES (variant));
- DECL_ATTRIBUTES (variant) = attr;
- return;
- }
- if ((TREE_VALUE (attr) != NULL_TREE) != (construct != NULL_TREE)
- || (construct != NULL_TREE
- && omp_context_selector_set_compare ("construct", TREE_VALUE (attr),
- construct)))
- error_at (loc, "%qD used as a variant with incompatible %<construct%> "
- "selector sets", variant);
-}
-
/* For OpenACC, the OMP_CLAUSE_MAP_KIND of an OMP_CLAUSE_MAP is used internally
to distinguish clauses as seen by the user. Return the "friendly" clause
name for error messages etc., where possible. See also
diff --git a/gcc/c/c-parser.c b/gcc/c/c-parser.c
index 869a811ed90..80dd61d599e 100644
--- a/gcc/c/c-parser.c
+++ b/gcc/c/c-parser.c
@@ -21694,7 +21694,7 @@ c_finish_omp_declare_variant (c_parser *parser, tree fndecl, tree parms)
tree ctx = c_parser_omp_context_selector_specification (parser, parms);
if (ctx == error_mark_node)
goto fail;
- ctx = c_omp_check_context_selector (match_loc, ctx);
+ ctx = omp_check_context_selector (match_loc, ctx);
if (ctx != error_mark_node && variant != error_mark_node)
{
if (TREE_CODE (variant) != FUNCTION_DECL)
@@ -21724,7 +21724,7 @@ c_finish_omp_declare_variant (c_parser *parser, tree fndecl, tree parms)
{
C_DECL_USED (variant) = 1;
tree construct = omp_get_context_selector (ctx, "construct", NULL);
- c_omp_mark_declare_variant (match_loc, variant, construct);
+ omp_mark_declare_variant (match_loc, variant, construct);
if (omp_context_selector_matches (ctx))
{
tree attr
diff --git a/gcc/cp/decl.c b/gcc/cp/decl.c
index 561debe6a0e..242429d9ef4 100644
--- a/gcc/cp/decl.c
+++ b/gcc/cp/decl.c
@@ -7768,7 +7768,7 @@ omp_declare_variant_finalize_one (tree decl, tree attr)
else
{
tree construct = omp_get_context_selector (ctx, "construct", NULL);
- c_omp_mark_declare_variant (match_loc, variant, construct);
+ omp_mark_declare_variant (match_loc, variant, construct);
if (!omp_context_selector_matches (ctx))
return true;
TREE_PURPOSE (TREE_VALUE (attr)) = variant;
diff --git a/gcc/cp/parser.c b/gcc/cp/parser.c
index 0818d66be07..865778e4d30 100644
--- a/gcc/cp/parser.c
+++ b/gcc/cp/parser.c
@@ -45319,7 +45319,7 @@ cp_finish_omp_declare_variant (cp_parser *parser, cp_token *pragma_tok,
tree ctx = cp_parser_omp_context_selector_specification (parser, true);
if (ctx == error_mark_node)
goto fail;
- ctx = c_omp_check_context_selector (match_loc, ctx);
+ ctx = omp_check_context_selector (match_loc, ctx);
if (ctx != error_mark_node && variant != error_mark_node)
{
tree match_loc_node = maybe_wrap_with_location (integer_zero_node,
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index b2b0254a3c3..5b9f89748d2 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -239,7 +239,7 @@ enum gfc_statement
ST_OMP_DO_SIMD, ST_OMP_END_DO_SIMD, ST_OMP_PARALLEL_DO_SIMD,
ST_OMP_END_PARALLEL_DO_SIMD, ST_OMP_DECLARE_SIMD, ST_OMP_DECLARE_REDUCTION,
ST_OMP_TARGET, ST_OMP_END_TARGET, ST_OMP_TARGET_DATA, ST_OMP_END_TARGET_DATA,
- ST_OMP_TARGET_UPDATE, ST_OMP_DECLARE_TARGET,
+ ST_OMP_TARGET_UPDATE, ST_OMP_DECLARE_TARGET, ST_OMP_DECLARE_VARIANT,
ST_OMP_TEAMS, ST_OMP_END_TEAMS, ST_OMP_DISTRIBUTE, ST_OMP_END_DISTRIBUTE,
ST_OMP_DISTRIBUTE_SIMD, ST_OMP_END_DISTRIBUTE_SIMD,
ST_OMP_DISTRIBUTE_PARALLEL_DO, ST_OMP_END_DISTRIBUTE_PARALLEL_DO,
@@ -1553,6 +1553,73 @@ typedef struct gfc_omp_declare_simd
gfc_omp_declare_simd;
#define gfc_get_omp_declare_simd() XCNEW (gfc_omp_declare_simd)
+
+enum gfc_omp_trait_property_kind
+{
+ CTX_PROPERTY_NONE,
+ CTX_PROPERTY_USER,
+ CTX_PROPERTY_NAME_LIST,
+ CTX_PROPERTY_ID,
+ CTX_PROPERTY_EXPR,
+ CTX_PROPERTY_SIMD
+};
+
+typedef struct gfc_omp_trait_property
+{
+ struct gfc_omp_trait_property *next;
+ enum gfc_omp_trait_property_kind property_kind;
+ bool is_name : 1;
+
+ union
+ {
+ gfc_expr *expr;
+ gfc_symbol *sym;
+ gfc_omp_clauses *clauses;
+ char *name;
+ };
+} gfc_omp_trait_property;
+#define gfc_get_omp_trait_property() XCNEW (gfc_omp_trait_property)
+
+typedef struct gfc_omp_selector
+{
+ struct gfc_omp_selector *next;
+
+ char *trait_selector_name;
+ gfc_expr *score;
+ struct gfc_omp_trait_property *properties;
+} gfc_omp_selector;
+#define gfc_get_omp_selector() XCNEW (gfc_omp_selector)
+
+typedef struct gfc_omp_set_selector
+{
+ struct gfc_omp_set_selector *next;
+
+ const char *trait_set_selector_name;
+ struct gfc_omp_selector *trait_selectors;
+} gfc_omp_set_selector;
+#define gfc_get_omp_set_selector() XCNEW (gfc_omp_set_selector)
+
+
+/* Node in the linked list used for storing !$omp declare variant
+ constructs. */
+
+typedef struct gfc_omp_declare_variant
+{
+ struct gfc_omp_declare_variant *next;
+ locus where; /* Where the !$omp declare variant construct occurred. */
+
+ struct gfc_symtree *base_proc_symtree;
+ struct gfc_symtree *variant_proc_symtree;
+
+ gfc_omp_set_selector *set_selectors;
+
+ bool checked_p : 1; /* Set if previously checked for errors. */
+ bool error_p : 1; /* Set if error found in directive. */
+}
+gfc_omp_declare_variant;
+#define gfc_get_omp_declare_variant() XCNEW (gfc_omp_declare_variant)
+
+
typedef struct gfc_omp_udr
{
struct gfc_omp_udr *next;
@@ -2022,6 +2089,9 @@ typedef struct gfc_namespace
/* Linked list of !$omp declare simd constructs. */
struct gfc_omp_declare_simd *omp_declare_simd;
+ /* Linked list of !$omp declare variant constructs. */
+ struct gfc_omp_declare_variant *omp_declare_variant;
+
/* A hash set for the the gfc expressions that have already
been finalized in this namespace. */
@@ -3422,6 +3492,7 @@ bool gfc_omp_requires_add_clause (gfc_omp_requires_kind, const char *,
void gfc_check_omp_requires (gfc_namespace *, int);
void gfc_free_omp_clauses (gfc_omp_clauses *);
void gfc_free_oacc_declare_clauses (struct gfc_oacc_declare *);
+void gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list);
void gfc_free_omp_declare_simd (gfc_omp_declare_simd *);
void gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *);
void gfc_free_omp_udr (gfc_omp_udr *);
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 92fd127a57f..21e94f79d95 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -160,6 +160,7 @@ match gfc_match_omp_critical (void);
match gfc_match_omp_declare_reduction (void);
match gfc_match_omp_declare_simd (void);
match gfc_match_omp_declare_target (void);
+match gfc_match_omp_declare_variant (void);
match gfc_match_omp_depobj (void);
match gfc_match_omp_distribute (void);
match gfc_match_omp_distribute_parallel_do (void);
diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index 6a4ca2868f8..2a161f3304c 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -168,6 +168,70 @@ gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list)
}
}
+static void
+gfc_free_omp_trait_property_list (gfc_omp_trait_property *list)
+{
+ while (list)
+ {
+ gfc_omp_trait_property *current = list;
+ list = list->next;
+ switch (current->property_kind)
+ {
+ case CTX_PROPERTY_ID:
+ free (current->name);
+ break;
+ case CTX_PROPERTY_NAME_LIST:
+ if (current->is_name)
+ free (current->name);
+ break;
+ case CTX_PROPERTY_SIMD:
+ gfc_free_omp_clauses (current->clauses);
+ break;
+ default:
+ break;
+ }
+ free (current);
+ }
+}
+
+static void
+gfc_free_omp_selector_list (gfc_omp_selector *list)
+{
+ while (list)
+ {
+ gfc_omp_selector *current = list;
+ list = list->next;
+ gfc_free_omp_trait_property_list (current->properties);
+ free (current);
+ }
+}
+
+static void
+gfc_free_omp_set_selector_list (gfc_omp_set_selector *list)
+{
+ while (list)
+ {
+ gfc_omp_set_selector *current = list;
+ list = list->next;
+ gfc_free_omp_selector_list (current->trait_selectors);
+ free (current);
+ }
+}
+
+/* Free an !$omp declare variant construct list. */
+
+void
+gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list)
+{
+ while (list)
+ {
+ gfc_omp_declare_variant *current = list;
+ list = list->next;
+ gfc_free_omp_set_selector_list (current->set_selectors);
+ free (current);
+ }
+}
+
/* Free an !$omp declare reduction. */
void
@@ -1353,7 +1417,7 @@ gfc_match_dupl_atomic (bool not_dupl, const char *name)
static match
gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
bool first = true, bool needs_space = true,
- bool openacc = false)
+ bool openacc = false, bool context_selector = false)
{
bool error = false;
gfc_omp_clauses *c = gfc_get_omp_clauses ();
@@ -2843,7 +2907,9 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
}
end:
- if (error || gfc_match_omp_eos () != MATCH_YES)
+ if (error
+ || (context_selector && gfc_peek_ascii_char () != ')')
+ || (!context_selector && gfc_match_omp_eos () != MATCH_YES))
{
if (!gfc_error_flag_test ())
gfc_error ("Failed to match clause at %C");
@@ -4429,6 +4495,449 @@ cleanup:
}
+static const char *const omp_construct_selectors[] = {
+ "simd", "target", "teams", "parallel", "do", NULL };
+static const char *const omp_device_selectors[] = {
+ "kind", "isa", "arch", NULL };
+static const char *const omp_implementation_selectors[] = {
+ "vendor", "extension", "atomic_default_mem_order", "unified_address",
+ "unified_shared_memory", "dynamic_allocators", "reverse_offload", NULL };
+static const char *const omp_user_selectors[] = {
+ "condition", NULL };
+
+
+/* OpenMP 5.0:
+
+ trait-selector:
+ trait-selector-name[([trait-score:]trait-property[,trait-property[,...]])]
+
+ trait-score:
+ score(score-expression) */
+
+match
+gfc_match_omp_context_selector (gfc_omp_set_selector *oss)
+{
+ do
+ {
+ char selector[GFC_MAX_SYMBOL_LEN + 1];
+
+ if (gfc_match_name (selector) != MATCH_YES)
+ {
+ gfc_error ("expected trait selector name at %C");
+ return MATCH_ERROR;
+ }
+
+ gfc_omp_selector *os = gfc_get_omp_selector ();
+ os->trait_selector_name = XNEWVEC (char, strlen (selector) + 1);
+ strcpy (os->trait_selector_name, selector);
+ os->next = oss->trait_selectors;
+ oss->trait_selectors = os;
+
+ const char *const *selectors = NULL;
+ bool allow_score = true;
+ bool allow_user = false;
+ int property_limit = 0;
+ enum gfc_omp_trait_property_kind property_kind = CTX_PROPERTY_NONE;
+ switch (oss->trait_set_selector_name[0])
+ {
+ case 'c': /* construct */
+ selectors = omp_construct_selectors;
+ allow_score = false;
+ property_limit = 1;
+ property_kind = CTX_PROPERTY_SIMD;
+ break;
+ case 'd': /* device */
+ selectors = omp_device_selectors;
+ allow_score = false;
+ allow_user = true;
+ property_limit = 3;
+ property_kind = CTX_PROPERTY_NAME_LIST;
+ break;
+ case 'i': /* implementation */
+ selectors = omp_implementation_selectors;
+ allow_user = true;
+ property_limit = 3;
+ property_kind = CTX_PROPERTY_NAME_LIST;
+ break;
+ case 'u': /* user */
+ selectors = omp_user_selectors;
+ property_limit = 1;
+ property_kind = CTX_PROPERTY_EXPR;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ for (int i = 0; ; i++)
+ {
+ if (selectors[i] == NULL)
+ {
+ if (allow_user)
+ {
+ property_kind = CTX_PROPERTY_USER;
+ break;
+ }
+ else
+ {
+ gfc_error ("selector '%s' not allowed for context selector "
+ "set '%s' at %C",
+ selector, oss->trait_set_selector_name);
+ return MATCH_ERROR;
+ }
+ }
+ if (i == property_limit)
+ property_kind = CTX_PROPERTY_NONE;
+ if (strcmp (selectors[i], selector) == 0)
+ break;
+ }
+ if (property_kind == CTX_PROPERTY_NAME_LIST
+ && oss->trait_set_selector_name[0] == 'i'
+ && strcmp (selector, "atomic_default_mem_order") == 0)
+ property_kind = CTX_PROPERTY_ID;
+
+ if (gfc_match (" (") == MATCH_YES)
+ {
+ if (property_kind == CTX_PROPERTY_NONE)
+ {
+ gfc_error ("selector '%s' does not accept any properties at %C",
+ selector);
+ return MATCH_ERROR;
+ }
+
+ if (allow_score && gfc_match (" score") == MATCH_YES)
+ {
+ if (gfc_match (" (") != MATCH_YES)
+ {
+ gfc_error ("expected '(' at %C");
+ return MATCH_ERROR;
+ }
+ if (gfc_match_expr (&os->score) != MATCH_YES
+ || !gfc_resolve_expr (os->score)
+ || os->score->ts.type != BT_INTEGER
+ || os->score->rank != 0)
+ {
+ gfc_error ("score argument must be constant integer "
+ "expression at %C");
+ return MATCH_ERROR;
+ }
+
+ if (os->score->expr_type == EXPR_CONSTANT
+ && mpz_sgn (os->score->value.integer) < 0)
+ {
+ gfc_error ("score argument must be non-negative at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match (" )") != MATCH_YES)
+ {
+ gfc_error ("expected ')' at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match (" :") != MATCH_YES)
+ {
+ gfc_error ("expected : at %C");
+ return MATCH_ERROR;
+ }
+ }
+
+ gfc_omp_trait_property *otp = gfc_get_omp_trait_property ();
+ otp->property_kind = property_kind;
+ otp->next = os->properties;
+ os->properties = otp;
+
+ switch (property_kind)
+ {
+ case CTX_PROPERTY_USER:
+ do
+ {
+ if (gfc_match_expr (&otp->expr) != MATCH_YES)
+ {
+ gfc_error ("property must be constant integer "
+ "expression or string literal at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match (" ,") != MATCH_YES)
+ break;
+ }
+ while (1);
+ break;
+ case CTX_PROPERTY_ID:
+ {
+ char buf[GFC_MAX_SYMBOL_LEN + 1];
+ if (gfc_match_name (buf) == MATCH_YES)
+ {
+ otp->name = XNEWVEC (char, strlen (buf) + 1);
+ strcpy (otp->name, buf);
+ }
+ else
+ {
+ gfc_error ("expected identifier at %C");
+ return MATCH_ERROR;
+ }
+ }
+ break;
+ case CTX_PROPERTY_NAME_LIST:
+ do
+ {
+ char buf[GFC_MAX_SYMBOL_LEN + 1];
+ if (gfc_match_name (buf) == MATCH_YES)
+ {
+ otp->name = XNEWVEC (char, strlen (buf) + 1);
+ strcpy (otp->name, buf);
+ otp->is_name = true;
+ }
+ else if (gfc_match_literal_constant (&otp->expr, 0)
+ != MATCH_YES
+ || otp->expr->ts.type != BT_CHARACTER)
+ {
+ gfc_error ("expected identifier or string literal "
+ "at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match (" ,") == MATCH_YES)
+ {
+ otp = gfc_get_omp_trait_property ();
+ otp->property_kind = property_kind;
+ otp->next = os->properties;
+ os->properties = otp;
+ }
+ else
+ break;
+ }
+ while (1);
+ break;
+ case CTX_PROPERTY_EXPR:
+ if (gfc_match_expr (&otp->expr) != MATCH_YES)
+ {
+ gfc_error ("expected expression at %C");
+ return MATCH_ERROR;
+ }
+ if (!gfc_resolve_expr (otp->expr)
+ || (otp->expr->ts.type != BT_LOGICAL
+ && otp->expr->ts.type != BT_INTEGER)
+ || otp->expr->rank != 0)
+ {
+ gfc_error ("property must be constant integer or logical "
+ "expression at %C");
+ return MATCH_ERROR;
+ }
+ break;
+ case CTX_PROPERTY_SIMD:
+ {
+ if (gfc_match_omp_clauses (&otp->clauses,
+ OMP_DECLARE_SIMD_CLAUSES,
+ true, false, false, true)
+ != MATCH_YES)
+ {
+ gfc_error ("expected simd clause at %C");
+ return MATCH_ERROR;
+ }
+ break;
+ }
+ default:
+ gcc_unreachable ();
+ }
+
+ if (gfc_match (" )") != MATCH_YES)
+ {
+ gfc_error ("expected ')' at %C");
+ return MATCH_ERROR;
+ }
+ }
+ else if (property_kind == CTX_PROPERTY_NAME_LIST
+ || property_kind == CTX_PROPERTY_ID
+ || property_kind == CTX_PROPERTY_EXPR)
+ {
+ if (gfc_match (" (") != MATCH_YES)
+ {
+ gfc_error ("expected '(' at %C");
+ return MATCH_ERROR;
+ }
+ }
+
+ if (gfc_match (" ,") != MATCH_YES)
+ break;
+ }
+ while (1);
+
+ return MATCH_YES;
+}
+
+/* OpenMP 5.0:
+
+ trait-set-selector[,trait-set-selector[,...]]
+
+ trait-set-selector:
+ trait-set-selector-name = { trait-selector[, trait-selector[, ...]] }
+
+ trait-set-selector-name:
+ constructor
+ device
+ implementation
+ user */
+
+match
+gfc_match_omp_context_selector_specification (gfc_omp_declare_variant *odv)
+{
+ do
+ {
+ match m;
+ const char *selector_sets[] = { "construct", "device",
+ "implementation", "user" };
+ const int selector_set_count
+ = sizeof (selector_sets) / sizeof (*selector_sets);
+ int i;
+ char buf[GFC_MAX_SYMBOL_LEN + 1];
+
+ m = gfc_match_name (buf);
+ if (m == MATCH_YES)
+ for (i = 0; i < selector_set_count; i++)
+ if (strcmp (buf, selector_sets[i]) == 0)
+ break;
+
+ if (m != MATCH_YES || i == selector_set_count)
+ {
+ gfc_error ("expected 'construct', 'device', 'implementation' or "
+ "'user' at %C");
+ return MATCH_ERROR;
+ }
+
+ m = gfc_match (" =");
+ if (m != MATCH_YES)
+ {
+ gfc_error ("expected '=' at %C");
+ return MATCH_ERROR;
+ }
+
+ m = gfc_match (" {");
+ if (m != MATCH_YES)
+ {
+ gfc_error ("expected '{' at %C");
+ return MATCH_ERROR;
+ }
+
+ gfc_omp_set_selector *oss = gfc_get_omp_set_selector ();
+ oss->next = odv->set_selectors;
+ oss->trait_set_selector_name = selector_sets[i];
+ odv->set_selectors = oss;
+
+ if (gfc_match_omp_context_selector (oss) != MATCH_YES)
+ return MATCH_ERROR;
+
+ m = gfc_match (" }");
+ if (m != MATCH_YES)
+ {
+ gfc_error ("expected '}' at %C");
+ return MATCH_ERROR;
+ }
+
+ m = gfc_match (" ,");
+ if (m != MATCH_YES)
+ break;
+ }
+ while (1);
+
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_declare_variant (void)
+{
+ bool first_p = true;
+ char buf[GFC_MAX_SYMBOL_LEN + 1];
+
+ if (gfc_match (" (") != MATCH_YES)
+ {
+ gfc_error ("expected '(' at %C");
+ return MATCH_ERROR;
+ }
+
+ gfc_symtree *base_proc_st, *variant_proc_st;
+ if (gfc_match_name (buf) != MATCH_YES)
+ {
+ gfc_error ("expected name at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_get_ha_sym_tree (buf, &base_proc_st))
+ return MATCH_ERROR;
+
+ if (gfc_match (" :") == MATCH_YES)
+ {
+ if (gfc_match_name (buf) != MATCH_YES)
+ {
+ gfc_error ("expected variant name at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_get_ha_sym_tree (buf, &variant_proc_st))
+ return MATCH_ERROR;
+ }
+ else
+ {
+ /* Base procedure not specified. */
+ variant_proc_st = base_proc_st;
+ base_proc_st = NULL;
+ }
+
+ gfc_omp_declare_variant *odv;
+ odv = gfc_get_omp_declare_variant ();
+ odv->where = gfc_current_locus;
+ odv->variant_proc_symtree = variant_proc_st;
+ odv->base_proc_symtree = base_proc_st;
+ odv->next = NULL;
+ odv->error_p = false;
+
+ /* Add the new declare variant to the end of the list. */
+ gfc_omp_declare_variant **prev_next = &gfc_current_ns->omp_declare_variant;
+ while (*prev_next)
+ prev_next = &((*prev_next)->next);
+ *prev_next = odv;
+
+ if (gfc_match (" )") != MATCH_YES)
+ {
+ gfc_error ("expected ')' at %C");
+ return MATCH_ERROR;
+ }
+
+ for (;;)
+ {
+ if (gfc_match (" match") != MATCH_YES)
+ {
+ if (first_p)
+ {
+ gfc_error ("expected 'match' at %C");
+ return MATCH_ERROR;
+ }
+ else
+ break;
+ }
+
+ if (gfc_match (" (") != MATCH_YES)
+ {
+ gfc_error ("expected '(' at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match_omp_context_selector_specification (odv) != MATCH_YES)
+ return MATCH_ERROR;
+
+ if (gfc_match (" )") != MATCH_YES)
+ {
+ gfc_error ("expected ')' at %C");
+ return MATCH_ERROR;
+ }
+
+ first_p = false;
+ }
+
+ return MATCH_YES;
+}
+
+
match
gfc_match_omp_threadprivate (void)
{
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 7d765a0866d..2a454be79b0 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -26,6 +26,8 @@ along with GCC; see the file COPYING3. If not see
#include <setjmp.h>
#include "match.h"
#include "parse.h"
+#include "tree-core.h"
+#include "omp-general.h"
/* Current statement label. Zero means no statement label. Because new_st
can get wiped during statement matching, we have to keep it separate. */
@@ -860,6 +862,8 @@ decode_omp_directive (void)
ST_OMP_DECLARE_SIMD);
matchdo ("declare target", gfc_match_omp_declare_target,
ST_OMP_DECLARE_TARGET);
+ matchdo ("declare variant", gfc_match_omp_declare_variant,
+ ST_OMP_DECLARE_VARIANT);
break;
case 's':
matchs ("simd", gfc_match_omp_simd, ST_OMP_SIMD);
@@ -1718,6 +1722,7 @@ next_statement (void)
#define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \
case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION: \
+ case ST_OMP_DECLARE_VARIANT: \
case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE
/* Block end statements. Errors associated with interchanging these
@@ -2361,6 +2366,9 @@ gfc_ascii_statement (gfc_statement st)
case ST_OMP_DECLARE_TARGET:
p = "!$OMP DECLARE TARGET";
break;
+ case ST_OMP_DECLARE_VARIANT:
+ p = "!$OMP DECLARE VARIANT";
+ break;
case ST_OMP_DEPOBJ:
p = "!$OMP DEPOBJ";
break;
@@ -6793,6 +6801,24 @@ done:
gfc_current_ns = gfc_current_ns->sibling)
gfc_check_omp_requires (gfc_current_ns, omp_requires);
+ /* Populate omp_requires_mask (needed for resolving OpenMP
+ metadirectives and declare variant). */
+ switch (omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
+ {
+ case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST:
+ omp_requires_mask
+ = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_SEQ_CST);
+ break;
+ case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL:
+ omp_requires_mask
+ = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_ACQ_REL);
+ break;
+ case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED:
+ omp_requires_mask
+ = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_RELAXED);
+ break;
+ }
+
/* Do the parse tree dump. */
gfc_current_ns = flag_dump_fortran_original ? gfc_global_ns_list : NULL;
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 6d61bf4982b..2c4acd5abe1 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -4046,6 +4046,7 @@ gfc_free_namespace (gfc_namespace *ns)
free_tb_tree (ns->tb_uop_root);
gfc_free_finalizer_list (ns->finalizers);
gfc_free_omp_declare_simd_list (ns->omp_declare_simd);
+ gfc_free_omp_declare_variant_list (ns->omp_declare_variant);
gfc_free_charlen (ns->cl_list, NULL);
free_st_labels (ns->st_labels);
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 87455f8ce25..7da1d2ebdcf 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -2362,9 +2362,13 @@ module_sym:
pushdecl_top_level (fndecl);
if (sym->formal_ns
- && sym->formal_ns->proc_name == sym
- && sym->formal_ns->omp_declare_simd)
- gfc_trans_omp_declare_simd (sym->formal_ns);
+ && sym->formal_ns->proc_name == sym)
+ {
+ if (sym->formal_ns->omp_declare_simd)
+ gfc_trans_omp_declare_simd (sym->formal_ns);
+ if (flag_openmp)
+ gfc_trans_omp_declare_variant (sym->formal_ns);
+ }
return fndecl;
}
@@ -3112,6 +3116,12 @@ gfc_create_function_decl (gfc_namespace * ns, bool global)
if (ns->omp_declare_simd)
gfc_trans_omp_declare_simd (ns);
+
+ /* Handle 'declare variant' directives. The applicable directives might
+ 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);
}
/* Return the decl used to hold the function return value. If
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index d234d1b070f..37d23310e3e 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -7258,3 +7258,207 @@ gfc_trans_omp_declare_simd (gfc_namespace *ns)
DECL_ATTRIBUTES (fndecl) = c;
}
}
+
+void
+gfc_trans_omp_declare_variant (gfc_namespace *ns)
+{
+ tree base_fn_decl = ns->proc_name->backend_decl;
+ gfc_namespace *search_ns = ns;
+ gfc_omp_declare_variant *next;
+
+ for (gfc_omp_declare_variant *odv = search_ns->omp_declare_variant;
+ search_ns; odv = next)
+ {
+ /* Look in the parent namespace if there are no more directives in the
+ current namespace. */
+ if (!odv)
+ {
+ search_ns = search_ns->parent;
+ if (search_ns)
+ next = search_ns->omp_declare_variant;
+ continue;
+ }
+
+ next = odv->next;
+
+ if (odv->error_p)
+ continue;
+
+ /* Check directive the first time it is encountered. */
+ bool error_found = true;
+
+ if (odv->checked_p)
+ error_found = false;
+ if (odv->base_proc_symtree == NULL)
+ {
+ if (!search_ns->proc_name->attr.function
+ && !search_ns->proc_name->attr.subroutine)
+ gfc_error ("The base name for 'declare variant' must be "
+ "specified at %L ", &odv->where);
+ else
+ error_found = false;
+ }
+ else
+ {
+ if (!search_ns->contained
+ && strcmp (odv->base_proc_symtree->name,
+ ns->proc_name->name))
+ gfc_error ("The base name at %L does not match the name of the "
+ "current procedure", &odv->where);
+ else if (odv->base_proc_symtree->n.sym->attr.entry)
+ gfc_error ("The base name at %L must not be an entry name",
+ &odv->where);
+ else if (odv->base_proc_symtree->n.sym->attr.generic)
+ gfc_error ("The base name at %L must not be a generic name",
+ &odv->where);
+ else if (odv->base_proc_symtree->n.sym->attr.proc_pointer)
+ gfc_error ("The base name at %L must not be a procedure pointer",
+ &odv->where);
+ else if (odv->base_proc_symtree->n.sym->attr.implicit_type)
+ gfc_error ("The base procedure at %L must have an explicit "
+ "interface", &odv->where);
+ else
+ error_found = false;
+ }
+
+ odv->checked_p = true;
+ if (error_found)
+ {
+ odv->error_p = true;
+ continue;
+ }
+
+ /* 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)))
+ continue;
+
+ tree set_selectors = NULL_TREE;
+ gfc_omp_set_selector *oss;
+
+ for (oss = odv->set_selectors; oss; oss = oss->next)
+ {
+ tree selectors = NULL_TREE;
+ gfc_omp_selector *os;
+ for (os = oss->trait_selectors; os; os = os->next)
+ {
+ tree properties = NULL_TREE;
+ gfc_omp_trait_property *otp;
+
+ for (otp = os->properties; otp; otp = otp->next)
+ {
+ switch (otp->property_kind)
+ {
+ case CTX_PROPERTY_USER:
+ case CTX_PROPERTY_EXPR:
+ {
+ gfc_se se;
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, otp->expr);
+ properties = tree_cons (NULL_TREE, se.expr,
+ properties);
+ }
+ break;
+ case CTX_PROPERTY_ID:
+ properties = tree_cons (get_identifier (otp->name),
+ NULL_TREE, properties);
+ break;
+ case CTX_PROPERTY_NAME_LIST:
+ {
+ tree prop = NULL_TREE, value = NULL_TREE;
+ if (otp->is_name)
+ prop = get_identifier (otp->name);
+ else
+ value = gfc_conv_constant_to_tree (otp->expr);
+
+ properties = tree_cons (prop, value, properties);
+ }
+ break;
+ case CTX_PROPERTY_SIMD:
+ properties = gfc_trans_omp_clauses (NULL, otp->clauses,
+ odv->where, true);
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ }
+
+ if (os->score)
+ {
+ gfc_se se;
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, os->score);
+ properties = tree_cons (get_identifier (" score"),
+ se.expr, properties);
+ }
+
+ selectors = tree_cons (get_identifier (os->trait_selector_name),
+ properties, selectors);
+ }
+
+ set_selectors
+ = tree_cons (get_identifier (oss->trait_set_selector_name),
+ selectors, set_selectors);
+ }
+
+ const char *variant_proc_name = odv->variant_proc_symtree->name;
+ gfc_symbol *variant_proc_sym = odv->variant_proc_symtree->n.sym;
+ if (variant_proc_sym == NULL || variant_proc_sym->attr.implicit_type)
+ {
+ gfc_symtree *proc_st;
+ gfc_find_sym_tree (variant_proc_name, gfc_current_ns, 1, &proc_st);
+ variant_proc_sym = proc_st->n.sym;
+ }
+ if (variant_proc_sym == NULL)
+ {
+ gfc_error ("Cannot find symbol %qs", variant_proc_name);
+ continue;
+ }
+ set_selectors = omp_check_context_selector
+ (gfc_get_location (&odv->where), set_selectors);
+ if (set_selectors != error_mark_node)
+ {
+ if (!variant_proc_sym->attr.implicit_type
+ && !variant_proc_sym->attr.subroutine
+ && !variant_proc_sym->attr.function)
+ {
+ gfc_error ("variant %qs at %L is not a function or subroutine",
+ variant_proc_name, &odv->where);
+ variant_proc_sym = NULL;
+ }
+ else if (omp_get_context_selector (set_selectors, "construct",
+ "simd") == NULL_TREE)
+ {
+ char err[256];
+ if (!gfc_compare_interfaces (ns->proc_name, variant_proc_sym,
+ variant_proc_sym->name, 0, 1,
+ err, sizeof (err), NULL, NULL))
+ {
+ gfc_error ("variant %qs and base %qs at %L have "
+ "incompatible types: %s",
+ variant_proc_name, ns->proc_name->name,
+ &odv->where, err);
+ variant_proc_sym = NULL;
+ }
+ }
+ if (variant_proc_sym != NULL)
+ {
+ gfc_set_sym_referenced (variant_proc_sym);
+ tree construct = omp_get_context_selector (set_selectors,
+ "construct", NULL);
+ omp_mark_declare_variant (gfc_get_location (&odv->where),
+ gfc_get_symbol_decl (variant_proc_sym),
+ construct);
+ if (omp_context_selector_matches (set_selectors))
+ {
+ tree id = get_identifier ("omp declare variant base");
+ tree variant = gfc_get_symbol_decl (variant_proc_sym);
+ DECL_ATTRIBUTES (base_fn_decl)
+ = tree_cons (id, build_tree_list (variant, set_selectors),
+ DECL_ATTRIBUTES (base_fn_decl));
+ }
+ }
+ }
+ }
+}
diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h
index 763f8940404..1a24d9b4cdc 100644
--- a/gcc/fortran/trans-stmt.h
+++ b/gcc/fortran/trans-stmt.h
@@ -71,6 +71,7 @@ tree gfc_trans_deallocate_array (tree);
/* trans-openmp.c */
tree gfc_trans_omp_directive (gfc_code *);
void gfc_trans_omp_declare_simd (gfc_namespace *);
+void gfc_trans_omp_declare_variant (gfc_namespace *);
tree gfc_trans_oacc_directive (gfc_code *);
tree gfc_trans_oacc_declare (gfc_namespace *);
diff --git a/gcc/omp-general.c b/gcc/omp-general.c
index 3e5ca94c2a7..44527552413 100644
--- a/gcc/omp-general.c
+++ b/gcc/omp-general.c
@@ -1095,6 +1095,146 @@ omp_maybe_offloaded (void)
return false;
}
+
+/* Diagnose errors in an OpenMP context selector, return CTX if
+ it is correct or error_mark_node otherwise. */
+
+tree
+omp_check_context_selector (location_t loc, tree ctx)
+{
+ /* Each trait-set-selector-name can only be specified once.
+ There are just 4 set names. */
+ for (tree t1 = ctx; t1; t1 = TREE_CHAIN (t1))
+ for (tree t2 = TREE_CHAIN (t1); t2; t2 = TREE_CHAIN (t2))
+ if (TREE_PURPOSE (t1) == TREE_PURPOSE (t2))
+ {
+ error_at (loc, "selector set %qs specified more than once",
+ IDENTIFIER_POINTER (TREE_PURPOSE (t1)));
+ return error_mark_node;
+ }
+ for (tree t = ctx; t; t = TREE_CHAIN (t))
+ {
+ /* Each trait-selector-name can only be specified once. */
+ if (list_length (TREE_VALUE (t)) < 5)
+ {
+ for (tree t1 = TREE_VALUE (t); t1; t1 = TREE_CHAIN (t1))
+ for (tree t2 = TREE_CHAIN (t1); t2; t2 = TREE_CHAIN (t2))
+ if (TREE_PURPOSE (t1) == TREE_PURPOSE (t2))
+ {
+ error_at (loc,
+ "selector %qs specified more than once in set %qs",
+ IDENTIFIER_POINTER (TREE_PURPOSE (t1)),
+ IDENTIFIER_POINTER (TREE_PURPOSE (t)));
+ return error_mark_node;
+ }
+ }
+ else
+ {
+ hash_set<tree> pset;
+ for (tree t1 = TREE_VALUE (t); t1; t1 = TREE_CHAIN (t1))
+ if (pset.add (TREE_PURPOSE (t1)))
+ {
+ error_at (loc,
+ "selector %qs specified more than once in set %qs",
+ IDENTIFIER_POINTER (TREE_PURPOSE (t1)),
+ IDENTIFIER_POINTER (TREE_PURPOSE (t)));
+ return error_mark_node;
+ }
+ }
+
+ static const char *const kind[] = {
+ "host", "nohost", "cpu", "gpu", "fpga", "any", NULL };
+ static const char *const vendor[] = {
+ "amd", "arm", "bsc", "cray", "fujitsu", "gnu", "ibm", "intel",
+ "llvm", "nvidia", "pgi", "ti", "unknown", NULL };
+ static const char *const extension[] = { NULL };
+ static const char *const atomic_default_mem_order[] = {
+ "seq_cst", "relaxed", "acq_rel", NULL };
+ struct known_properties { const char *set; const char *selector;
+ const char *const *props; };
+ known_properties props[] = {
+ { "device", "kind", kind },
+ { "implementation", "vendor", vendor },
+ { "implementation", "extension", extension },
+ { "implementation", "atomic_default_mem_order",
+ atomic_default_mem_order } };
+ for (tree t1 = TREE_VALUE (t); t1; t1 = TREE_CHAIN (t1))
+ for (unsigned i = 0; i < ARRAY_SIZE (props); i++)
+ if (!strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t1)),
+ props[i].selector)
+ && !strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)),
+ props[i].set))
+ for (tree t2 = TREE_VALUE (t1); t2; t2 = TREE_CHAIN (t2))
+ for (unsigned j = 0; ; j++)
+ {
+ if (props[i].props[j] == NULL)
+ {
+ if (TREE_PURPOSE (t2)
+ && !strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t2)),
+ " score"))
+ break;
+ if (props[i].props == atomic_default_mem_order)
+ {
+ error_at (loc,
+ "incorrect property %qs of %qs selector",
+ IDENTIFIER_POINTER (TREE_PURPOSE (t2)),
+ "atomic_default_mem_order");
+ return error_mark_node;
+ }
+ else if (TREE_PURPOSE (t2))
+ warning_at (loc, 0,
+ "unknown property %qs of %qs selector",
+ IDENTIFIER_POINTER (TREE_PURPOSE (t2)),
+ props[i].selector);
+ else
+ warning_at (loc, 0,
+ "unknown property %qE of %qs selector",
+ TREE_VALUE (t2), props[i].selector);
+ break;
+ }
+ else if (TREE_PURPOSE (t2) == NULL_TREE)
+ {
+ const char *str = TREE_STRING_POINTER (TREE_VALUE (t2));
+ if (!strcmp (str, props[i].props[j])
+ && ((size_t) TREE_STRING_LENGTH (TREE_VALUE (t2))
+ == strlen (str) + (lang_GNU_Fortran () ? 0 : 1)))
+ break;
+ }
+ else if (!strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t2)),
+ props[i].props[j]))
+ break;
+ }
+ }
+ return ctx;
+}
+
+
+/* Register VARIANT as variant of some base function marked with
+ #pragma omp declare variant. CONSTRUCT is corresponding construct
+ selector set. */
+
+void
+omp_mark_declare_variant (location_t loc, tree variant, tree construct)
+{
+ tree attr = lookup_attribute ("omp declare variant variant",
+ DECL_ATTRIBUTES (variant));
+ if (attr == NULL_TREE)
+ {
+ attr = tree_cons (get_identifier ("omp declare variant variant"),
+ unshare_expr (construct),
+ DECL_ATTRIBUTES (variant));
+ DECL_ATTRIBUTES (variant) = attr;
+ return;
+ }
+ if ((TREE_VALUE (attr) != NULL_TREE) != (construct != NULL_TREE)
+ || (construct != NULL_TREE
+ && omp_context_selector_set_compare ("construct", TREE_VALUE (attr),
+ construct)))
+ error_at (loc, "%qD used as a variant with incompatible %<construct%> "
+ "selector sets", variant);
+}
+
+
/* Return a name from PROP, a property in selectors accepting
name lists. */
@@ -1106,7 +1246,8 @@ omp_context_name_list_prop (tree prop)
else
{
const char *ret = TREE_STRING_POINTER (TREE_VALUE (prop));
- if ((size_t) TREE_STRING_LENGTH (TREE_VALUE (prop)) == strlen (ret) + 1)
+ if ((size_t) TREE_STRING_LENGTH (TREE_VALUE (prop))
+ == strlen (ret) + (lang_GNU_Fortran () ? 0 : 1))
return ret;
return NULL;
}
diff --git a/gcc/omp-general.h b/gcc/omp-general.h
index 6a1468d2798..8fe744c6a7a 100644
--- a/gcc/omp-general.h
+++ b/gcc/omp-general.h
@@ -104,6 +104,9 @@ extern tree find_combined_omp_for (tree *, int *, void *);
extern poly_uint64 omp_max_vf (void);
extern int omp_max_simt_vf (void);
extern int omp_constructor_traits_to_codes (tree, enum tree_code *);
+extern tree omp_check_context_selector (location_t loc, tree ctx);
+extern void omp_mark_declare_variant (location_t loc, tree variant,
+ tree construct);
extern int omp_context_selector_matches (tree);
extern int omp_context_selector_set_compare (const char *, tree, tree);
extern tree omp_get_context_selector (tree, const char *, const char *);
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-1.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-1.f90
new file mode 100644
index 00000000000..de09dbfe806
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-1.f90
@@ -0,0 +1,93 @@
+module main
+ implicit none
+
+ interface
+ integer function foo (a, b, c)
+ integer, intent(in) :: a, b
+ integer, intent(inout) :: c
+ end function
+
+ integer function bar (a, b, c)
+ integer, intent(in) :: a, b
+ integer, intent(inout) :: c
+ end function
+
+ integer function baz (a, b, c)
+ integer, intent(in) :: a, b
+ integer, intent(inout) :: c
+
+ !$omp declare variant (foo) &
+ !$omp & match (construct={parallel,do}, &
+ !$omp & device={isa(avx512f,avx512vl),kind(host,cpu)}, &
+ !$omp & implementation={vendor(score(0):gnu),unified_shared_memory}, &
+ !$omp & user={condition(score(0):0)})
+ !$omp declare variant (bar) &
+ !$omp & match (device={arch(x86_64,powerpc64),isa(avx512f,popcntb)}, &
+ !$omp & implementation={atomic_default_mem_order(seq_cst),made_up_selector("foo", 13, "bar")}, &
+ !$omp & user={condition(3-3)})
+ end function
+
+ subroutine quux
+ end subroutine quux
+
+ integer function baz3 (x, y, z)
+ integer, intent(in) :: x, y
+ integer, intent(inout) :: z
+
+ !$omp declare variant (bar) match &
+ !$omp & (implementation={atomic_default_mem_order(score(3): acq_rel)})
+ end function
+ end interface
+contains
+ integer function qux ()
+ integer :: i = 3
+
+ qux = baz (1, 2, i)
+ end function
+
+ subroutine corge
+ integer :: i
+ !$omp declare variant (quux) match (construct={parallel,do})
+
+ interface
+ subroutine waldo (x)
+ integer, intent(in) :: x
+ end subroutine
+ end interface
+
+ call waldo (5)
+ !$omp parallel do
+ do i = 1, 3
+ call waldo (6)
+ end do
+ !$omp end parallel do
+
+ !$omp parallel
+ !$omp taskgroup
+ !$omp do
+ do i = 1, 3
+ call waldo (7)
+ end do
+ !$omp end do
+ !$omp end taskgroup
+ !$omp end parallel
+
+ !$omp parallel
+ !$omp master
+ call waldo (8)
+ !$omp end master
+ !$omp end parallel
+ end subroutine
+
+ integer function baz2 (x, y, z)
+ integer, intent(in) :: x, y
+ integer, intent(inout) :: z
+
+ !$omp declare variant (bar) match &
+ !$omp & (implementation={atomic_default_mem_order(relaxed), &
+ !$omp & unified_address, unified_shared_memory, &
+ !$omp & dynamic_allocators, reverse_offload})
+
+ baz2 = x + y + z
+ end function
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-10.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-10.f90
new file mode 100644
index 00000000000..d6d2c8c262b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-10.f90
@@ -0,0 +1,97 @@
+! { dg-do compile }
+! { dg-additional-options "-cpp -foffload=disable -fdump-tree-gimple" }
+! { dg-additional-options "-mavx512bw" { target { i?86-*-* x86_64-*-* } } }
+
+#undef i386
+
+program main
+ !$omp declare target to (test3)
+contains
+ subroutine f01 ()
+ end subroutine
+ subroutine f02 ()
+ !$omp declare variant (f01) match (device={isa(avx512f,avx512bw)})
+ end subroutine
+ subroutine f03 ()
+ end subroutine
+ subroutine f04 ()
+ !$omp declare variant (f03) match (device={kind("any"),arch(x86_64),isa(avx512f,avx512bw)})
+ end subroutine
+ subroutine f05 ()
+ end subroutine
+ subroutine f06 ()
+ !$omp declare variant (f05) match (device={kind(gpu)})
+ end subroutine
+ subroutine f07 ()
+ end subroutine
+ subroutine f08 ()
+ !$omp declare variant (f07) match (device={kind(cpu)})
+ end subroutine
+ subroutine f09 ()
+ end subroutine
+ subroutine f10 ()
+ !$omp declare variant (f09) match (device={isa(sm_35)})
+ end subroutine
+ subroutine f11 ()
+ end subroutine
+ subroutine f12 ()
+ !$omp declare variant (f11) match (device={arch("nvptx")})
+ end subroutine
+ subroutine f13 ()
+ end subroutine
+ subroutine f14 ()
+ !$omp declare variant (f13) match (device={arch(i386),isa("sse4")})
+ end subroutine
+ subroutine f15 ()
+ end subroutine
+ subroutine f16 ()
+ !$omp declare variant (f15) match (device={isa(sse4,ssse3),arch(i386)})
+ end subroutine
+ subroutine f17 ()
+ end subroutine
+ subroutine f18 ()
+ !$omp declare variant (f17) match (device={kind(any,fpga)})
+ end subroutine
+
+ subroutine test1 ()
+ !$omp declare target
+ integer :: i
+
+ call f02 () ! { dg-final { scan-tree-dump-times "f01 \\\(\\\);" 1 "gimple" { target i?86-*-* x86_64-*-* } } }
+ ! { dg-final { scan-tree-dump-times "f02 \\\(\\\);" 1 "gimple" { target { ! { i?86-*-* x86_64-*-* } } } } }
+ call f14 () ! { dg-final { scan-tree-dump-times "f13 \\\(\\\);" 1 "gimple" { target ia32 } } }
+ ! { dg-final { scan-tree-dump-times "f14 \\\(\\\);" 1 "gimple" { target { ! ia32 } } } }
+ call f18 () ! { dg-final { scan-tree-dump-times "f18 \\\(\\\);" 1 "gimple" } } */
+ end subroutine
+
+#if defined(__i386__) || defined(__x86_64__)
+ __attribute__((target ("avx512f,avx512bw")))
+#endif
+ subroutine test2 ()
+ !$omp target
+ call f04 () ! { dg-final { scan-tree-dump-times "f03 \\\(\\\);" 1 "gimple" { target { { i?86-*-* x86_64-*-* } && lp64 } } } }
+ ! { dg-final { scan-tree-dump-times "f04 \\\(\\\);" 1 "gimple" { target { { ! lp64 } || { ! { i?86-*-* x86_64-*-* } } } } } }
+ !$omp end target
+ !$omp target
+ call f16 () ! { dg-final { scan-tree-dump-times "f15 \\\(\\\);" 1 "gimple" { target ia32 } } }
+ ! { dg-final { scan-tree-dump-times "f16 \\\(\\\);" 1 "gimple" { target { ! ia32 } } } }
+ !$omp end target
+ end subroutine
+
+ subroutine test3 ()
+ call f06 () ! { dg-final { scan-tree-dump-times "f06 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* amdgcn*-*-* } } } } }
+ call f08 () ! { dg-final { scan-tree-dump-times "f07 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* amdgcn*-*-* } } } } }
+ end subroutine
+
+ subroutine test4 ()
+ !$omp target
+ call f10 () ! { dg-final { scan-tree-dump-times "f10 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* amdgcn*-*-* } } } } }
+ !$omp end target
+
+ !$omp target
+ call f12 () ! { dg-final { scan-tree-dump-times "f12 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* } } } } }
+ ! { dg-final { scan-tree-dump-times "f11 \\\(\\\);" 1 "gimple" { target { nvptx*-*-* } } } }
+ !$omp end target
+ end subroutine
+end program
+
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-11.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-11.f90
new file mode 100644
index 00000000000..60aa0fcb3b0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-11.f90
@@ -0,0 +1,134 @@
+! { dg-do compile }
+! { dg-additional-options "-foffload=disable -fdump-tree-gimple" }
+! { dg-additional-options "-mavx512bw -mavx512vl" { target { i?86-*-* x86_64-*-* } } }
+
+program main
+ implicit none
+contains
+ subroutine f01 ()
+ end subroutine
+
+ subroutine f02 ()
+ end subroutine
+
+ subroutine f03 ()
+ !$omp declare variant (f01) match (device={isa(avx512f,"avx512vl")})
+ !$omp declare variant (f02) match (device={isa(avx512bw,avx512vl,"avx512f")})
+ end subroutine
+
+ subroutine f04 ()
+ end subroutine
+
+ subroutine f05 ()
+ end subroutine
+
+ subroutine f06 ()
+ !$omp declare variant (f04) match (device={isa(avx512f,avx512vl)})
+ !$omp declare variant (f05) match (device={isa(avx512bw,avx512vl,avx512f)})
+ end subroutine
+
+ subroutine f07 ()
+ end subroutine
+
+ subroutine f08 ()
+ end subroutine
+
+ subroutine f09 ()
+ !$omp declare variant (f07) match (device={isa(sse4,"sse4.1","sse4.2",sse3,"avx")})
+ !$omp declare variant (f08) match (device={isa("avx",sse3)})
+ end subroutine
+
+ subroutine f10 ()
+ end subroutine
+
+ subroutine f11 ()
+ end subroutine
+
+ subroutine f12 ()
+ end subroutine
+
+ subroutine f13 ()
+ !$omp declare variant (f10) match (device={isa("avx512f")})
+ !$omp declare variant (f11) match (user={condition(1)},device={isa(avx512f)},implementation={vendor(gnu)})
+ !$omp declare variant (f12) match (user={condition(2 + 1)},device={isa(avx512f)})
+ end subroutine
+
+ subroutine f14 ()
+ end subroutine
+
+ subroutine f15 ()
+ end subroutine
+
+ subroutine f16 ()
+ end subroutine
+
+ subroutine f17 ()
+ end subroutine
+
+ subroutine f18 ()
+ !$omp declare variant (f14) match (construct={teams,do})
+ !$omp declare variant (f15) match (construct={teams,parallel,do})
+ !$omp declare variant (f16) match (construct={do})
+ !$omp declare variant (f17) match (construct={parallel,do})
+ end subroutine
+
+ subroutine f19 ()
+ end subroutine
+
+ subroutine f20 ()
+ end subroutine
+
+ subroutine f21 ()
+ end subroutine
+
+ subroutine f22 ()
+ end subroutine
+
+ subroutine f23 ()
+ !$omp declare variant (f19) match (construct={teams,do})
+ !$omp declare variant (f20) match (construct={teams,parallel,do})
+ !$omp declare variant (f21) match (construct={do})
+ !$omp declare variant (f22) match (construct={parallel,do})
+ end subroutine
+
+ subroutine f24 ()
+ end subroutine
+
+ subroutine f25 ()
+ end subroutine
+
+ subroutine f26 ()
+ end subroutine
+
+ subroutine f27 ()
+ !$omp declare variant (f24) match (device={kind(cpu)})
+ !$omp declare variant (f25) match (device={kind(cpu),isa(avx512f),arch(x86_64)})
+ !$omp declare variant (f26) match (device={arch(x86_64),kind(cpu)})
+ end subroutine
+
+ subroutine test1
+ integer :: i
+ call f03 () ! { dg-final { scan-tree-dump-times "f02 \\\(\\\);" 1 "gimple" { target i?86-*-* x86_64-*-* } } }
+ ! { dg-final { scan-tree-dump-times "f03 \\\(\\\);" 1 "gimple" { target { ! { i?86-*-* x86_64-*-* } } } } }
+ call f09 () ! { dg-final { scan-tree-dump-times "f07 \\\(\\\);" 1 "gimple" { target i?86-*-* x86_64-*-* } } }
+ ! { dg-final { scan-tree-dump-times "f09 \\\(\\\);" 1 "gimple" { target { ! { i?86-*-* x86_64-*-* } } } } }
+ call f13 () ! { dg-final { scan-tree-dump-times "f11 \\\(\\\);" 1 "gimple" { target i?86-*-* x86_64-*-* } } }
+ ! { dg-final { scan-tree-dump-times "f13 \\\(\\\);" 1 "gimple" { target { ! { i?86-*-* x86_64-*-* } } } } }
+ !$omp teams distribute parallel do
+ do i = 1, 2
+ call f18 () ! { dg-final { scan-tree-dump-times "f15 \\\(\\\);" 1 "gimple" } }
+ end do
+ !$omp end teams distribute parallel do
+
+ !$omp parallel do
+ do i = 1, 2
+ call f23 () ! { dg-final { scan-tree-dump-times "f22 \\\(\\\);" 1 "gimple" } }
+ end do
+ !$omp end parallel do
+
+ call f27 () ! { dg-final { scan-tree-dump-times "f25 \\\(\\\);" 1 "gimple" { target { { i?86-*-* x86_64-*-* } && lp64 } } } }
+ ! { dg-final { scan-tree-dump-times "f24 \\\(\\\);" 1 "gimple" { target { { i?86-*-* x86_64-*-* } && { ! lp64 } } } } }
+ ! { dg-final { scan-tree-dump-times "f24 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* amdgcn*-*-* i?86-*-* x86_64-*-* } } } } }
+ ! { dg-final { scan-tree-dump-times "f27 \\\(\\\);" 1 "gimple" { target { nvptx*-*-* amdgcn*-*-* } } } }
+ end subroutine
+end program
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-12.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-12.f90
new file mode 100644
index 00000000000..610693e9807
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-12.f90
@@ -0,0 +1,159 @@
+! { dg-do compile }
+! { dg-additional-options "-foffload=disable -fdump-tree-gimple" }
+! { dg-additional-options "-mavx512bw -mavx512vl" { target { i?86-*-* x86_64-*-* } } }
+
+program main
+ !$omp requires atomic_default_mem_order(seq_cst)
+contains
+ subroutine f01 ()
+ end subroutine
+
+ subroutine f02 ()
+ end subroutine
+
+ subroutine f03 ()
+ end subroutine
+
+ subroutine f04 ()
+ !$omp declare variant (f01) match (device={isa("avx512f","avx512vl")}) ! 16
+ !$omp declare variant (f02) match (implementation={vendor(score(15):gnu)})
+ !$omp declare variant (f03) match (user={condition(score(11):1)})
+ end subroutine
+
+ subroutine f05 ()
+ end subroutine
+
+ subroutine f06 ()
+ end subroutine
+
+ subroutine f07 ()
+ end subroutine
+
+ subroutine f08 ()
+ !$omp declare variant (f05) match (device={isa(avx512f,avx512vl)}) ! 16
+ !$omp declare variant (f06) match (implementation={vendor(score(15):gnu)})
+ !$omp declare variant (f07) match (user={condition(score(17):1)})
+ end subroutine
+
+ subroutine f09 ()
+ end subroutine
+
+ subroutine f10 ()
+ end subroutine
+
+ subroutine f11 ()
+ end subroutine
+
+ subroutine f12 ()
+ end subroutine
+
+ subroutine f13 ()
+ !$omp declare variant (f09) match (device={arch(x86_64)},user={condition(score(65):1)}) ! 64+65
+ !$omp declare variant (f10) match (implementation={vendor(score(127):"gnu")})
+ !$omp declare variant (f11) match (device={isa(ssse3)}) ! 128
+ !$omp declare variant (f12) match (implementation={atomic_default_mem_order(score(126):seq_cst)})
+ end subroutine
+
+ subroutine f14 ()
+ end subroutine
+
+ subroutine f15 ()
+ end subroutine
+
+ subroutine f16 ()
+ end subroutine
+
+ subroutine f17 ()
+ !$omp declare variant (f14) match (construct={teams,parallel,do}) ! 16+8+4
+ !$omp declare variant (f15) match (construct={parallel},user={condition(score(19):1)}) ! 8+19
+ !$omp declare variant (f16) match (implementation={atomic_default_mem_order(score(27):seq_cst)})
+ end subroutine
+
+ subroutine f18 ()
+ end subroutine
+
+ subroutine f19 ()
+ end subroutine
+
+ subroutine f20 ()
+ end subroutine
+
+ subroutine f21 ()
+ !$omp declare variant (f18) match (construct={teams,parallel,do}) ! 16+8+4
+ !$omp declare variant (f19) match (construct={do},user={condition(score(25):1)}) ! 4+25
+ !$omp declare variant (f20) match (implementation={atomic_default_mem_order(score(28):seq_cst)})
+ end subroutine
+
+ subroutine f22 ()
+ end subroutine
+
+ subroutine f23 ()
+ end subroutine
+
+ subroutine f24 ()
+ end subroutine
+
+ subroutine f25 ()
+ !$omp declare variant (f22) match (construct={parallel,do}) ! 2+1
+ !$omp declare variant (f23) match (construct={do}) ! 0
+ !$omp declare variant (f24) match (implementation={atomic_default_mem_order(score(2):seq_cst)})
+ end subroutine
+
+ subroutine f26 ()
+ end subroutine
+
+ subroutine f27 ()
+ end subroutine
+
+ subroutine f28 ()
+ end subroutine
+
+ subroutine f29 ()
+ !$omp declare variant (f26) match (construct={parallel,do}) ! 2+1
+ !$omp declare variant (f27) match (construct={do},user={condition(1)}) ! 4
+ !$omp declare variant (f28) match (implementation={atomic_default_mem_order(score(3):seq_cst)})
+ end subroutine
+
+ subroutine test1 ()
+ integer :: i, j
+
+ !$omp parallel do ! 2 constructs in OpenMP context, isa has score 2^4.
+ do i = 1, 2
+ call f04 () ! { dg-final { scan-tree-dump-times "f01 \\\(\\\);" 1 "gimple" { target i?86-*-* x86_64-*-* } } }
+ ! { dg-final { scan-tree-dump-times "f02 \\\(\\\);" 1 "gimple" { target { ! { i?86-*-* x86_64-*-* } } } } }
+ end do
+ !$omp end parallel do
+
+ !$omp target teams ! 2 constructs in OpenMP context, isa has score 2^4.
+ call f08 () ! { dg-final { scan-tree-dump-times "f07 \\\(\\\);" 1 "gimple" } }
+ !$omp end target teams
+
+ !$omp teams
+ !$omp parallel do
+ do i = 1, 2
+ !$omp parallel do ! 5 constructs in OpenMP context, arch is 2^6, isa 2^7.
+ do j = 1, 2
+ call f13 () ! { dg-final { scan-tree-dump-times "f09 \\\(\\\);" 1 "gimple" { target { { i?86-*-* x86_64-*-* } && lp64 } } } }
+ ! { dg-final { scan-tree-dump-times "f11 \\\(\\\);" 1 "gimple" { target { { i?86-*-* x86_64-*-* } && { ! lp64 } } } } }
+ ! { dg-final { scan-tree-dump-times "f10 \\\(\\\);" 1 "gimple" { target { ! { i?86-*-* x86_64-*-* } } } } }
+ call f17 () ! { dg-final { scan-tree-dump-times "f14 \\\(\\\);" 1 "gimple" } }
+ call f21 () ! { dg-final { scan-tree-dump-times "f19 \\\(\\\);" 1 "gimple" } }
+ end do
+ !$omp end parallel do
+ end do
+ !$omp end parallel do
+ !$omp end teams
+
+ !$omp do
+ do i = 1, 2
+ !$omp parallel do
+ do j = 1, 2
+ call f25 (); ! { dg-final { scan-tree-dump-times "f22 \\\(\\\);" 1 "gimple" } }
+ call f29 (); ! { dg-final { scan-tree-dump-times "f27 \\\(\\\);" 1 "gimple" } }
+ end do
+ !$omp end parallel do
+ end do
+ !$omp end do
+ end subroutine
+end program
+
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-13.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-13.f90
new file mode 100644
index 00000000000..91648f9bcf4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-13.f90
@@ -0,0 +1,48 @@
+! { dg-do compile { target vect_simd_clones } }
+! { dg-additional-options "-fdump-tree-gimple" }
+! { dg-additional-options "-mno-sse3" { target { i?86-*-* x86_64-*-* } } }
+
+program main
+ implicit none
+contains
+ integer function f01 (x)
+ integer, intent(in) :: x
+ f01 = x
+ end function
+
+ integer function f02 (x)
+ integer, intent(in) :: x
+ f02 = x
+ end function
+
+ integer function f03 (x)
+ integer, intent(in) :: x
+ f03 = x
+ end function
+
+ integer function f04 (x)
+ integer, intent(in) :: x
+ f04 = x
+ end function
+
+ integer function f05 (x)
+ integer, intent(in) :: x
+
+ !$omp declare variant (f01) match (device={isa("avx512f")}) ! 4 or 8
+ !$omp declare variant (f02) match (implementation={vendor(score(3):gnu)},device={kind(cpu)}) ! (1 or 2) + 3
+ !$omp declare variant (f03) match (user={condition(score(9):1)})
+ !$omp declare variant (f04) match (implementation={vendor(score(6):gnu)},device={kind(host)}) ! (1 or 2) + 6
+ f05 = x
+ end function
+
+ integer function test1 (x)
+ !$omp declare simd
+ integer, intent(in) :: x
+
+ ! 0 or 1 (the latter if in a declare simd clone) constructs in OpenMP context,
+ ! isa has score 2^2 or 2^3. We can't decide on whether avx512f will match or
+ ! not, that also depends on whether it is a declare simd clone or not and which
+ ! one, but the f03 variant has a higher score anyway. */
+ test1 = f05 (x) ! { dg-final { scan-tree-dump-times "f03 \\\(x" 1 "gimple" } }
+ end function
+end program
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-14.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-14.f90
new file mode 100644
index 00000000000..06c9a5d1ed8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-14.f90
@@ -0,0 +1,49 @@
+! { dg-do compile { target vect_simd_clones } }
+! { dg-additional-options "-O0 -fdump-tree-gimple -fdump-tree-optimized" }
+! { dg-additional-options "-mno-sse3" { target { i?86-*-* x86_64-*-* } } }
+
+module main
+ implicit none
+contains
+ integer function f01 (x)
+ integer, intent (in) :: x
+ f01 = x
+ end function
+
+ integer function f02 (x)
+ integer, intent (in) :: x
+ f02 = x
+ end function
+
+ integer function f03 (x)
+ integer, intent (in) :: x
+ f03 = x
+ end function
+
+ integer function f04 (x)
+ integer, intent(in) :: x
+
+ !$omp declare variant (f01) match (device={isa("avx512f")}) ! 4 or 8
+ !$omp declare variant (f02) match (implementation={vendor(score(3):gnu)},device={kind(cpu)}) ! (1 or 2) + 3
+ !$omp declare variant (f03) match (implementation={vendor(score(5):gnu)},device={kind(host)}) ! (1 or 2) + 5
+ f04 = x
+ end function
+
+ integer function test1 (x)
+ !$omp declare simd
+ integer, intent (in) :: x
+ integer :: a, b
+
+ ! At gimplification time, we can't decide yet which function to call.
+ ! { dg-final { scan-tree-dump-times "f04 \\\(x" 2 "gimple" } }
+ ! After simd clones are created, the original non-clone test1 shall
+ ! call f03 (score 6), the sse2/avx/avx2 clones too, but avx512f clones
+ ! shall call f01 with score 8.
+ ! { dg-final { scan-tree-dump-not "f04 \\\(x" "optimized" } }
+ ! { dg-final { scan-tree-dump-times "f03 \\\(x" 14 "optimized" } }
+ ! { dg-final { scan-tree-dump-times "f01 \\\(x" 4 "optimized" } }
+ a = f04 (x)
+ b = f04 (x)
+ test1 = a + b
+ end function
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-15.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-15.f90
new file mode 100644
index 00000000000..b2ad96a8998
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-15.f90
@@ -0,0 +1,24 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-gimple" }
+
+! Test 'declare variant' directive with an explicit base procedure name.
+
+module main
+ implicit none
+
+ !$omp declare variant (base: variant) match (construct={target,parallel})
+contains
+ subroutine variant ()
+ end subroutine
+
+ subroutine base ()
+ end subroutine
+
+ subroutine test1 ()
+ !$omp target
+ !$omp parallel
+ call base () ! { dg-final { scan-tree-dump-times "variant \\\(\\\);" 1 "gimple" } }
+ !$omp end parallel
+ !$omp end target
+ end subroutine
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-16.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-16.f90
new file mode 100644
index 00000000000..fc97322e667
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-16.f90
@@ -0,0 +1,24 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-gimple" }
+
+! Test that 'declare variant' works when applied to an external subroutine
+
+module main
+ implicit none
+
+ interface
+ subroutine base ()
+ !$omp declare variant (variant) match (construct={parallel})
+ end subroutine
+ end interface
+
+contains
+ subroutine variant ()
+ end subroutine
+
+ subroutine test ()
+ !$omp parallel
+ call base () ! { dg-final { scan-tree-dump-times "variant \\\(\\\);" 1 "gimple" } }
+ !$omp end parallel
+ end subroutine
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-17.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-17.f90
new file mode 100644
index 00000000000..df57f9c089c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-17.f90
@@ -0,0 +1,17 @@
+! { dg-do compile }
+
+! Declare variant directives should only appear in the specification parts.
+
+program main
+ implicit none
+
+ continue
+
+ !$omp declare variant (base: variant) match (construct={parallel}) ! { dg-error "Unexpected \\\!\\\$OMP DECLARE VARIANT statement at .1." }
+contains
+ subroutine base ()
+ continue
+
+ !$omp declare variant (variant) match (construct={parallel}) ! { dg-error "Unexpected \\\!\\\$OMP DECLARE VARIANT statement at .1." }
+ end subroutine
+end program
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-18.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-18.f90
new file mode 100644
index 00000000000..f97cf34a28a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-18.f90
@@ -0,0 +1,17 @@
+! { dg-do compile }
+
+! The base procedure must have an accessible explicit interface when the
+! directive appears.
+
+program main
+ interface
+ subroutine base_proc ()
+ end subroutine
+ end interface
+
+ !$omp declare variant (base_proc: variant_proc) match (construct={parallel})
+ !$omp declare variant (base_proc2: variant_proc) match (construct={parallel}) ! { dg-error "The base procedure at .1. must have an explicit interface" }
+contains
+ subroutine variant_proc ()
+ end subroutine
+end program
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-19.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-19.f90
new file mode 100644
index 00000000000..d387f5e9065
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-19.f90
@@ -0,0 +1,49 @@
+! { dg-do compile }
+
+! Test Fortran-specific compilation failures.
+
+module main
+ implicit none
+
+ interface base_gen
+ subroutine base_gen_int (x)
+ integer :: x
+ end subroutine
+
+ subroutine base_gen_real (x)
+ real :: x
+ end subroutine
+ end interface
+
+ interface
+ subroutine base_p ()
+ end subroutine
+ end interface
+
+ procedure (base_p), pointer :: base_proc_ptr
+
+ !$omp declare variant (base_entry: variant) match (construct={parallel}) ! { dg-error "The base name at .1. must not be an entry name" }
+ !$omp declare variant (base_proc_ptr: variant) match (construct={parallel}) ! { dg-error "The base name at .1. must not be a procedure pointer" }
+ !$omp declare variant (base_gen: variant2) match (construct={parallel}) ! { dg-error "The base name at .1. must not be a generic name" }
+ !$omp declare variant (variant) match (construct={parallel}) ! { dg-error "The base name for 'declare variant' must be specified at .1." }
+
+contains
+ subroutine base ()
+ entry base_entry
+ end subroutine
+
+ subroutine base2 ()
+ !$omp declare variant (variant2) match (construct={parallel}) ! { dg-error "variant .variant2. and base .base2. at .1. have incompatible types: .variant2. has the wrong number of arguments" }
+ end subroutine
+
+ subroutine base3 ()
+ !$omp declare variant (base: variant2) match (construct={parallel}) ! { dg-error "The base name at .1. does not match the name of the current procedure" }
+ end subroutine
+
+ subroutine variant ()
+ end subroutine
+
+ subroutine variant2 (x)
+ integer :: x
+ end subroutine
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90
new file mode 100644
index 00000000000..63d77780196
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90
@@ -0,0 +1,197 @@
+module main
+ implicit none
+contains
+ subroutine f0 ()
+ end subroutine
+ subroutine f1 ()
+ end subroutine
+ subroutine f2 ()
+ !$omp declare variant ! { dg-error "expected '\\(' at .1." }
+ end subroutine
+ subroutine f3 ()
+ !$omp declare variant ( ! { dg-error "" }
+ end subroutine
+ subroutine f4 ()
+ !$omp declare variant () ! { dg-error "" }
+ end subroutine
+ subroutine f5 ()
+ !$omp declare variant match(user={condition(0)}) ! { dg-error "expected '\\(' at .1." }
+ end subroutine
+ subroutine f6 ()
+ !$omp declare variant (f1) ! { dg-error "expected 'match' at .1." }
+ end subroutine
+ subroutine f7 ()
+ !$omp declare variant (f1) simd ! { dg-error "expected 'match' at .1." }
+ end subroutine
+ subroutine f8 ()
+ !$omp declare variant (f1) match ! { dg-error "expected '\\(' at .1." }
+ end subroutine
+ subroutine f9 ()
+ !$omp declare variant (f1) match( ! { dg-error "expected 'construct', 'device', 'implementation' or 'user' at .1." }
+ end subroutine
+ subroutine f10 ()
+ !$omp declare variant (f1) match() ! { dg-error "expected 'construct', 'device', 'implementation' or 'user' at .1." }
+ end subroutine
+ subroutine f11 ()
+ !$omp declare variant (f1) match(foo) ! { dg-error "expected 'construct', 'device', 'implementation' or 'user' at .1." }
+ end subroutine
+ subroutine f12 ()
+ !$omp declare variant (f1) match(something={something}) ! { dg-error "expected 'construct', 'device', 'implementation' or 'user' at .1." }
+ end subroutine
+ subroutine f13 ()
+ !$omp declare variant (f1) match(user) ! { dg-error "expected '=' at .1." }
+ end subroutine
+ subroutine f14 ()
+ !$omp declare variant (f1) match(user=) ! { dg-error "expected '\\\{' at .1." }
+ end subroutine
+ subroutine f15 ()
+ !$omp declare variant (f1) match(user= ! { dg-error "expected '\\\{' at .1." }
+ end subroutine
+ subroutine f16 ()
+ !$omp declare variant (f1) match(user={) ! { dg-error "expected trait selector name at .1." }
+ end subroutine
+ subroutine f17 ()
+ !$omp declare variant (f1) match(user={}) ! { dg-error "expected trait selector name at .1." }
+ end subroutine
+ subroutine f18 ()
+ !$omp declare variant (f1) match(user={condition}) ! { dg-error "expected '\\(' at .1." }
+ end subroutine
+ subroutine f19 ()
+ !$omp declare variant (f1) match(user={condition(}) ! { dg-error "expected expression at .1." }
+ end subroutine
+ subroutine f20 ()
+ !$omp declare variant (f1) match(user={condition()}) ! { dg-error "expected expression at .1." }
+ end subroutine
+ subroutine f21 ()
+ !$omp declare variant (f1) match(user={condition(f1)}) ! { dg-error "expected expression at .1." }
+ end subroutine
+ subroutine f22 ()
+ !$omp declare variant (f1) match(user={condition(1, 2, 3)}) ! { dg-error "expected '\\)' at .1." }
+ end subroutine
+ subroutine f23 ()
+ !$omp declare variant (f1) match(construct={master}) ! { dg-error "selector 'master' not allowed for context selector set 'construct' at .1." }
+ end subroutine
+ subroutine f24 ()
+ !$omp declare variant (f1) match(construct={teams,parallel,master,do}) ! { dg-error "selector 'master' not allowed for context selector set 'construct' at .1." }
+ end subroutine
+ subroutine f25 ()
+ !$omp declare variant (f1) match(construct={parallel(1 ! { dg-error "selector 'parallel' does not accept any properties at .1." }
+ end subroutine
+ subroutine f26 ()
+ !$omp declare variant (f1) match(construct={parallel(1)}) ! { dg-error "selector 'parallel' does not accept any properties at .1." }
+ end subroutine
+ subroutine f27 ()
+ !$omp declare variant (f0) match(construct={simd(12)}) ! { dg-error "expected simd clause at .1." }
+ end subroutine
+ subroutine f32 ()
+ !$omp declare variant (f1) match(device={kind}) ! { dg-error "expected '\\(' at .1." }
+ end subroutine
+ subroutine f33 ()
+ !$omp declare variant (f1) match(device={isa}) ! { dg-error "expected '\\(' at .1." }
+ end subroutine
+ subroutine f34 ()
+ !$omp declare variant (f1) match(device={arch}) ! { dg-error "expected '\\(' at .1." }
+ end subroutine
+ subroutine f35 ()
+ !$omp declare variant (f1) match(device={kind,isa,arch}) ! { dg-error "expected '\\(' at .1." }
+ end subroutine
+ subroutine f36 ()
+ !$omp declare variant (f1) match(device={kind(}) ! { dg-error "expected identifier or string literal at .1." }
+ end subroutine
+ subroutine f39 ()
+ !$omp declare variant (f1) match(device={isa(1)}) ! { dg-error "expected identifier or string literal at .1." }
+ end subroutine
+ subroutine f40 ()
+ !$omp declare variant (f1) match(device={arch(17)}) ! { dg-error "expected identifier or string literal at .1." }
+ end subroutine
+ subroutine f41 ()
+ !$omp declare variant (f1) match(device={foobar(3)})
+ end subroutine
+ subroutine f43 ()
+ !$omp declare variant (f1) match(implementation={foobar(3)})
+ end subroutine
+ subroutine f44 ()
+ !$omp declare variant (f1) match(implementation={vendor}) ! { dg-error "expected '\\(' at .1." }
+ end subroutine
+ subroutine f45 ()
+ !$omp declare variant (f1) match(implementation={extension}) ! { dg-error "expected '\\(' at .1." }
+ end subroutine
+ subroutine f45a ()
+ !$omp declare variant (f1) match(implementation={vendor()}) ! { dg-error "expected identifier or string literal at .1." }
+ end subroutine
+ subroutine f46 ()
+ !$omp declare variant (f1) match(implementation={vendor(123-234)}) ! { dg-error "expected identifier or string literal at .1." }
+ end subroutine
+ subroutine f48 ()
+ !$omp declare variant (f1) match(implementation={unified_address(yes)}) ! { dg-error "selector 'unified_address' does not accept any properties at .1." }
+ end subroutine
+ subroutine f49 ()
+ !$omp declare variant (f1) match(implementation={unified_shared_memory(no)}) ! { dg-error "selector 'unified_shared_memory' does not accept any properties at .1." }
+ end subroutine
+ subroutine f50 ()
+ !$omp declare variant (f1) match(implementation={dynamic_allocators(42)}) ! { dg-error "selector 'dynamic_allocators' does not accept any properties at .1." }
+ end subroutine
+ subroutine f51 ()
+ !$omp declare variant (f1) match(implementation={reverse_offload()}) ! { dg-error "selector 'reverse_offload' does not accept any properties at .1." }
+ end subroutine
+ subroutine f52 ()
+ !$omp declare variant (f1) match(implementation={atomic_default_mem_order}) ! { dg-error "expected '\\('" }
+ end subroutine
+ subroutine f56 ()
+ !$omp declare variant (f1) match(implementation={atomic_default_mem_order(relaxed,seq_cst)}) ! { dg-error "expected '\\)' at .1." }
+ end subroutine
+ subroutine f58 ()
+ !$omp declare variant (f1) match(user={foobar(3)}) ! { dg-error "selector 'foobar' not allowed for context selector set 'user' at .1." }
+ end subroutine
+ subroutine f59 ()
+ !$omp declare variant (f1) match(construct={foobar(3)}) ! { dg-error "selector 'foobar' not allowed for context selector set 'construct' at .1." }
+ end subroutine
+ subroutine f60 ()
+ !$omp declare variant (f1) match(construct={parallel},foobar={bar}) ! { dg-error "expected 'construct', 'device', 'implementation' or 'user' at .1." }
+ end subroutine
+ subroutine f64 ()
+ !$omp declare variant (f1) match(construct={single}) ! { dg-error "selector 'single' not allowed for context selector set 'construct' at .1." }
+ end subroutine
+ subroutine f65 ()
+ !$omp declare variant (f1) match(construct={taskgroup}) ! { dg-error "selector 'taskgroup' not allowed for context selector set 'construct' at .1." }
+ end subroutine
+ subroutine f66 ()
+ !$omp declare variant (f1) match(construct={for}) ! { dg-error "selector 'for' not allowed for context selector set 'construct' at .1." }
+ end subroutine
+ subroutine f67 ()
+ !$omp declare variant (f1) match(construct={threadprivate}) ! { dg-error "selector 'threadprivate' not allowed for context selector set 'construct' at .1." }
+ end subroutine
+ subroutine f68 ()
+ !$omp declare variant (f1) match(construct={critical}) ! { dg-error "selector 'critical' not allowed for context selector set 'construct' at .1." }
+ end subroutine
+ subroutine f69 ()
+ !$omp declare variant (f1) match(construct={task}) ! { dg-error "selector 'task' not allowed for context selector set 'construct' at .1." }
+ end subroutine
+ subroutine f70 ()
+ !$omp declare variant (f1) match(construct={taskloop}) ! { dg-error "selector 'taskloop' not allowed for context selector set 'construct' at .1." }
+ end subroutine
+ subroutine f71 ()
+ !$omp declare variant (f1) match(construct={sections}) ! { dg-error "selector 'sections' not allowed for context selector set 'construct' at .1." }
+ end subroutine
+ subroutine f72 ()
+ !$omp declare variant (f1) match(construct={section}) ! { dg-error "selector 'section' not allowed for context selector set 'construct' at .1." }
+ end subroutine
+ subroutine f73 ()
+ !$omp declare variant (f1) match(construct={workshare}) ! { dg-error "selector 'workshare' not allowed for context selector set 'construct' at .1." }
+ end subroutine
+ subroutine f74 ()
+ !$omp declare variant (f1) match(construct={requires}) ! { dg-error "selector 'requires' not allowed for context selector set 'construct' at .1." }
+ end subroutine
+ subroutine f75 ()
+ !$omp declare variant (f1),match(construct={parallel}) ! { dg-error "expected 'match' at .1." }
+ end subroutine
+ subroutine f76 ()
+ !$omp declare variant (f1) match(implementation={atomic_default_mem_order("relaxed")}) ! { dg-error "expected identifier at .1." }
+ end subroutine
+ subroutine f77 ()
+ !$omp declare variant (f1) match(user={condition(score(f76):1)}) ! { dg-error "score argument must be constant integer expression at .1." }
+ end subroutine
+ subroutine f78 ()
+ !$omp declare variant (f1) match(user={condition(score(-130):1)}) ! { dg-error "score argument must be non-negative" }
+ end subroutine
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-2a.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-2a.f90
new file mode 100644
index 00000000000..56de1177789
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-2a.f90
@@ -0,0 +1,53 @@
+module main
+ implicit none
+contains
+ subroutine f1 ()
+ end subroutine
+ subroutine f28 ()
+ !$omp declare variant (f1) match(construct={parallel},construct={do}) ! { dg-error "selector set 'construct' specified more than once" }
+ end subroutine
+ subroutine f29 ()
+ !$omp declare variant (f1) match(construct={parallel},construct={parallel}) ! { dg-error "selector set 'construct' specified more than once" }
+ end subroutine
+ subroutine f30 ()
+ !$omp declare variant (f1) match(user={condition(0)},construct={target},user={condition(0)}) ! { dg-error "selector set 'user' specified more than once" }
+ end subroutine
+ subroutine f31 ()
+ !$omp declare variant (f1) match(user={condition(0)},user={condition(1)}) ! { dg-error "selector set 'user' specified more than once" }
+ end subroutine
+ subroutine f37 ()
+ !$omp declare variant (f1) match(device={kind(unknown)}) ! { dg-warning "unknown property 'unknown' of 'kind' selector" }
+ end subroutine
+ subroutine f38 ()
+ !$omp declare variant (f1) match(device={kind(unknown,foobar)}) ! { dg-warning "unknown property 'unknown' of 'kind' selector" }
+ ! { dg-warning "unknown property 'foobar' of 'kind' selector" "" { target *-*-* } 22 }
+ end subroutine
+ subroutine f42 ()
+ !$omp declare variant (f1) match(device={arch(x86_64)},device={isa(avx512vl)}) ! { dg-error "selector set 'device' specified more than once" }
+ end subroutine
+ subroutine f47 ()
+ !$omp declare variant (f1) match(implementation={vendor("foobar")}) ! { dg-warning "unknown property '.foobar.' of 'vendor' selector" }
+ end subroutine
+ subroutine f53 ()
+ !$omp declare variant (f1) match(implementation={atomic_default_mem_order(acquire)}) ! { dg-error "incorrect property 'acquire' of 'atomic_default_mem_order' selector" }
+ end subroutine
+ subroutine f54 ()
+ !$omp declare variant (f1) match(implementation={atomic_default_mem_order(release)}) ! { dg-error "incorrect property 'release' of 'atomic_default_mem_order' selector" }
+ end subroutine
+ subroutine f55 ()
+ !$omp declare variant (f1) match(implementation={atomic_default_mem_order(foobar)}) ! { dg-error "incorrect property 'foobar' of 'atomic_default_mem_order' selector" }
+ end subroutine
+ subroutine f57 ()
+ !$omp declare variant (f1) match(implementation={atomic_default_mem_order(relaxed)},&
+ !$omp & implementation={atomic_default_mem_order(relaxed)}) ! { dg-error "selector set 'implementation' specified more than once" "" { target *-*-* } 41 }
+ end subroutine
+ subroutine f61 ()
+ !$omp declare variant (f1) match(construct={parallel,parallel}) ! { dg-error "selector 'parallel' specified more than once in set 'construct'" }
+ end subroutine
+ subroutine f62 ()
+ !$omp declare variant (f1) match(construct={target,parallel,do,simd,parallel}) ! { dg-error "selector 'parallel' specified more than once in set 'construct'" }
+ end subroutine
+ subroutine f63 ()
+ !$omp declare variant (f1) match(construct={target,teams,teams}) ! { dg-error "selector 'teams' specified more than once in set 'construct'" }
+ end subroutine
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-3.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-3.f90
new file mode 100644
index 00000000000..c62622b607b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-3.f90
@@ -0,0 +1,237 @@
+module main
+contains
+ subroutine f1 ()
+ end subroutine
+ subroutine f2 ()
+ !$omp declare variant (f1) match (construct={target})
+ end subroutine
+ subroutine f3 ()
+ end subroutine
+ subroutine f4 ()
+ !$omp declare variant (f3) match (construct={teams})
+ end subroutine
+ subroutine f5 ()
+ end subroutine
+ subroutine f6 ()
+ !$omp declare variant (f5) match (construct={parallel})
+ end subroutine
+ subroutine f7 ()
+ end subroutine
+ subroutine f8 ()
+ !$omp declare variant (f7) match (construct={do})
+ end subroutine
+ subroutine f9 ()
+ end subroutine
+ subroutine f10 ()
+ !$omp declare variant (f9) match (construct={target,teams,parallel,do})
+ end subroutine
+ subroutine f11 ()
+ end subroutine
+ subroutine f12 ()
+ !$omp declare variant (f11) match (construct={teams,do,parallel})
+ end subroutine
+ subroutine f13 ()
+ end subroutine
+ subroutine f14 ()
+ !$omp declare variant (f13) match (device={kind(any)})
+ end subroutine
+ subroutine f15 ()
+ !$omp declare variant (f13) match (device={kind("host")})
+ end subroutine
+ subroutine f16 ()
+ !$omp declare variant (f13) match (device={kind(nohost)})
+ end subroutine
+ subroutine f17 ()
+ !$omp declare variant (f13) match (device={kind(cpu)})
+ end subroutine
+ subroutine f18 ()
+ !$omp declare variant (f13) match (device={kind("gpu")})
+ end subroutine
+ subroutine f19 ()
+ !$omp declare variant (f13) match (device={kind(fpga)})
+ end subroutine
+ subroutine f20 ()
+ !$omp declare variant (f13) match (device={kind(any,any)})
+ end subroutine
+ subroutine f21 ()
+ !$omp declare variant (f13) match (device={kind(host,nohost)})
+ end subroutine
+ subroutine f22 ()
+ !$omp declare variant (f13) match (device={kind("cpu","gpu","fpga")})
+ end subroutine
+ subroutine f23 ()
+ !$omp declare variant (f13) match (device={kind(any,cpu,nohost)})
+ end subroutine
+ subroutine f24 ()
+ !$omp declare variant (f13) match (device={isa(avx)})
+ end subroutine
+ subroutine f25 ()
+ !$omp declare variant (f13) match (device={isa(sse4,"avx512f",avx512vl,avx512bw)})
+ end subroutine
+ subroutine f26 ()
+ !$omp declare variant (f13) match (device={arch("x86_64")})
+ end subroutine
+ subroutine f27 ()
+ !$omp declare variant (f13) match (device={arch(riscv64)})
+ end subroutine
+ subroutine f28 ()
+ !$omp declare variant (f13) match (device={arch(nvptx)})
+ end subroutine
+ subroutine f29 ()
+ !$omp declare variant (f13) match (device={arch(x86_64),isa("avx512f","avx512vl"),kind(cpu)})
+ end subroutine
+ subroutine f30 ()
+ !$omp declare variant (f13) match (implementation={vendor(amd)})
+ end subroutine
+ subroutine f31 ()
+ !$omp declare variant (f13) match (implementation={vendor(arm)})
+ end subroutine
+ subroutine f32 ()
+ !$omp declare variant (f13) match (implementation={vendor("bsc")})
+ end subroutine
+ subroutine f33 ()
+ !$omp declare variant (f13) match (implementation={vendor(cray)})
+ end subroutine
+ subroutine f34 ()
+ !$omp declare variant (f13) match (implementation={vendor(fujitsu)})
+ end subroutine
+ subroutine f35 ()
+ !$omp declare variant (f13) match (implementation={vendor(gnu)})
+ end subroutine
+ subroutine f36 ()
+ !$omp declare variant (f13) match (implementation={vendor(ibm)})
+ end subroutine
+ subroutine f37 ()
+ !$omp declare variant (f13) match (implementation={vendor("intel")})
+ end subroutine
+ subroutine f38 ()
+ !$omp declare variant (f13) match (implementation={vendor(llvm)})
+ end subroutine
+ subroutine f39 ()
+ !$omp declare variant (f13) match (implementation={vendor(pgi)})
+ end subroutine
+ subroutine f40 ()
+ !$omp declare variant (f13) match (implementation={vendor(ti)})
+ end subroutine
+ subroutine f41 ()
+ !$omp declare variant (f13) match (implementation={vendor(unknown)})
+ end subroutine
+ subroutine f42 ()
+ !$omp declare variant (f13) match (implementation={vendor(gnu,llvm,intel,ibm)})
+ end subroutine
+ subroutine f43 ()
+ !$omp declare variant (f13) match (implementation={extension(my_cute_extension)}) ! { dg-warning "unknown property 'my_cute_extension' of 'extension' selector" }
+ end subroutine
+ subroutine f44 ()
+ !$omp declare variant (f13) match (implementation={extension(some_other_ext,another_ext)}) ! { dg-warning "unknown property 'some_other_ext' of 'extension' selector" }
+ ! { dg-warning "unknown property 'another_ext' of 'extension' selector" "" { target *-*-* } .-1 }
+ end subroutine
+ subroutine f45 ()
+ !$omp declare variant (f13) match (implementation={unified_shared_memory})
+ end subroutine
+ subroutine f46 ()
+ !$omp declare variant (f13) match (implementation={unified_address})
+ end subroutine
+ subroutine f47 ()
+ !$omp declare variant (f13) match (implementation={dynamic_allocators})
+ end subroutine
+ subroutine f48 ()
+ !$omp declare variant (f13) match (implementation={reverse_offload})
+ end subroutine
+ subroutine f49 ()
+ !$omp declare variant (f13) match (implementation={atomic_default_mem_order(seq_cst)})
+ end subroutine
+ subroutine f50 ()
+ !$omp declare variant (f13) match (implementation={atomic_default_mem_order(relaxed)})
+ end subroutine
+ subroutine f51 ()
+ !$omp declare variant (f13) match (implementation={atomic_default_mem_order(acq_rel)})
+ end subroutine
+ subroutine f52 ()
+ !$omp declare variant (f14) match (implementation={atomic_default_mem_order(acq_rel),vendor(gnu),&
+ !$omp& unified_address,extension(foobar)}) ! { dg-warning "unknown property 'foobar' of 'extension' selector" "" { target *-*-* } .-1 }
+ end subroutine
+ subroutine f53 ()
+ !$omp declare variant (f13) match (implementation={vendor(score(3):amd)})
+ end subroutine
+ subroutine f54 ()
+ !$omp declare variant (f13) match (implementation={vendor(score(4):"arm")})
+ end subroutine
+ subroutine f55 ()
+ !$omp declare variant (f13) match (implementation={vendor(score(5):bsc)})
+ end subroutine
+ subroutine f56 ()
+ !$omp declare variant (f13) match (implementation={vendor(score(6):cray)})
+ end subroutine
+ subroutine f57 ()
+ !$omp declare variant (f13) match (implementation={vendor(score(7):fujitsu)})
+ end subroutine
+ subroutine f58 ()
+ !$omp declare variant (f13) match (implementation={vendor(score(8):gnu)})
+ end subroutine
+ subroutine f59 ()
+ !$omp declare variant (f13) match (implementation={vendor(score(9):ibm)})
+ end subroutine
+ subroutine f60 ()
+ !$omp declare variant (f13) match (implementation={vendor(score(10):intel)})
+ end subroutine
+ subroutine f61 ()
+ !$omp declare variant (f13) match (implementation={vendor(score(11):llvm)})
+ end subroutine
+ subroutine f62 ()
+ !$omp declare variant (f13) match (implementation={vendor(score(12):pgi)})
+ end subroutine
+ subroutine f63 ()
+ !$omp declare variant (f13) match (implementation={vendor(score(13):"ti")})
+ end subroutine
+ subroutine f64 ()
+ !$omp declare variant (f13) match (implementation={vendor(score(14):unknown)})
+ end subroutine
+ subroutine f65 ()
+ !$omp declare variant (f13) match (implementation={vendor(score(15):gnu,llvm,intel,ibm)})
+ end subroutine
+ subroutine f66 ()
+ !$omp declare variant (f13) match (implementation={extension(score(16):my_cute_extension)}) ! { dg-warning "unknown property 'my_cute_extension' of 'extension' selector" }
+ end subroutine
+ subroutine f67 ()
+ !$omp declare variant (f13) match (implementation={extension(score(17):some_other_ext,another_ext)}) ! { dg-warning "unknown property 'some_other_ext' of 'extension' selector" }
+ end subroutine ! { dg-warning "unknown property 'another_ext' of 'extension' selector" "" { target *-*-* } .-1 }
+ subroutine f68 ()
+ !$omp declare variant (f13) match (implementation={atomic_default_mem_order(score(18):seq_cst)})
+ end subroutine
+ subroutine f69 ()
+ !$omp declare variant (f13) match (implementation={atomic_default_mem_order(score(19):relaxed)})
+ end subroutine
+ subroutine f70 ()
+ !$omp declare variant (f13) match (implementation={atomic_default_mem_order(score(20):acq_rel)})
+ end subroutine
+ subroutine f71 ()
+ !$omp declare variant (f13) match (implementation={atomic_default_mem_order(score(21):acq_rel),&
+ !$omp& vendor(score(22):gnu),unified_address,extension(score(22):foobar)}) ! { dg-warning "unknown property 'foobar' of 'extension' selector" "" { target *-*-* } .-1 }
+ end subroutine
+ subroutine f72 ()
+ !$omp declare variant (f13) match (user={condition(0)})
+ end subroutine
+ subroutine f73 ()
+ !$omp declare variant (f13) match (user={condition(272-272*1)})
+ end subroutine
+ subroutine f74 ()
+ !$omp declare variant (f13) match (user={condition(score(25):1)})
+ end subroutine
+ subroutine f75 ()
+ !$omp declare variant (f13) match (device={kind(any,"any")})
+ end subroutine
+ subroutine f76 ()
+ !$omp declare variant (f13) match (device={kind("any","any")})
+ end subroutine
+ subroutine f77 ()
+ !$omp declare variant (f13) match (device={kind("any",any)})
+ end subroutine
+ subroutine f78 ()
+ !$omp declare variant (f13) match (implementation={vendor(nvidia)})
+ end subroutine
+ subroutine f79 ()
+ !$omp declare variant (f13) match (user={condition(score(0):0)})
+ end subroutine
+
+ end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-4.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-4.f90
new file mode 100644
index 00000000000..bc4f41647b4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-4.f90
@@ -0,0 +1,62 @@
+program main
+ implicit none
+contains
+ function f6 (x, y, z)
+ real (kind = 8) :: f6
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real (kind = 4), intent(in) :: z
+
+ interface
+ function f1 (x, y, z)
+ real (kind = 8) :: f1
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real (kind = 4), intent(in) :: z
+ end function
+
+ function f2 (x, y, z)
+ real (kind = 8) :: f2
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real (kind = 4), intent(in) :: z
+ end function
+
+ function f3 (x, y, z)
+ real (kind = 8) :: f3
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real (kind = 4), intent(in) :: z
+ end function
+
+ function f4 (x, y, z)
+ real (kind = 8) :: f4
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real (kind = 4), intent(in) :: z
+ end function
+
+ function f5 (x, y, z)
+ real (kind = 8) :: f5
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real (kind = 4), intent(in) :: z
+ end function
+ end interface
+
+ !$omp declare variant (f1) match (user={condition(1)})
+ !$omp declare variant (f2) match (user={condition(score(1):1)})
+ !$omp declare variant (f3) match (user={condition(score(3):1)})
+ !$omp declare variant (f4) match (user={condition(score(2):1)})
+ !$omp declare variant (f5) match (implementation={vendor(gnu)})
+
+ f6 = z + x + y
+ end function
+
+ function test (x)
+ real (kind = 8) :: test
+ integer, intent(in) :: x
+
+ test = f6 (x, int (x, kind = 8), 3.5)
+ end function
+end program
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-5.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-5.f90
new file mode 100644
index 00000000000..ad7acb9842d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-5.f90
@@ -0,0 +1,75 @@
+! { dg-do compile { target i?86-*-* x86_64-*-* } }
+! { dg-additional-options "-mavx2" }
+
+module main
+ implicit none
+contains
+ function f1 (x, y, z)
+ integer, dimension(4) :: f1
+ real, dimension(4), intent(in) :: x, y
+ real, intent(out) :: z
+
+ f1 = x
+ end function
+
+ function f2 (x, y, z)
+ integer, dimension(8) :: f2
+ real, dimension(8), intent(in) :: x, y
+ real, intent(out) :: z
+
+ f2 = x
+ end function
+
+ function f3 (x, y, z)
+ integer, dimension(4) :: f3
+ real, dimension(4), intent(in) :: x, z
+ integer, intent(in) :: y
+
+ f3 = x
+ end function
+
+ integer function f4 (x, y, z)
+ real, intent(in) :: x, y
+ real, intent(out) :: z
+ !$omp declare variant (f1) match (construct={parallel,do,simd(simdlen(4),notinbranch,uniform(z),aligned(z:16))})
+ !$omp declare variant (f2) match (construct={do,simd(uniform(z),simdlen(8),notinbranch)})
+ end function
+
+ integer function f5 (x, y)
+ integer, intent(in) :: x, y
+ !$omp declare variant (f3) match (construct={simd(simdlen(4),inbranch,linear(y:1))})
+ end function
+
+ subroutine test (x, y, z, w)
+ integer, dimension(8192), intent(inout) :: x
+ real, dimension(8192), intent(inout) :: y, z
+ real, pointer, intent(out) :: w
+ integer :: i
+
+ !$omp parallel
+ !$omp do simd aligned (w:16)
+ do i = 1, 1024
+ x(i) = f4 (y(i), z(i), w)
+ end do
+ !$omp end do simd
+ !$omp end parallel
+
+ !$omp parallel do simd aligned (w:16) simdlen(4)
+ do i = 1025, 2048
+ x(i) = f4 (y(i), z(i), w)
+ end do
+ !$omp end parallel do simd
+
+ !$omp simd aligned (w:16)
+ do i = 2049, 4096
+ x(i) = f4 (y(i), z(i), w)
+ end do
+ !$omp end simd
+
+ !$omp simd
+ do i = 4097, 8192
+ if (x(i) .gt. 10) x(i) = f5 (x(i), i)
+ end do
+ !$omp end simd
+ end subroutine
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-6.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-6.f90
new file mode 100644
index 00000000000..3f33f38b9bc
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-6.f90
@@ -0,0 +1,188 @@
+module main
+ implicit none
+contains
+ function f1 (x, y, z)
+ real (kind = 8) :: f1
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+
+ f1 = 0.0
+ end function
+
+ function f2 (x, y, z)
+ real (kind = 8) :: f2
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+
+ f2 = 0.0
+ end function
+
+ function f3 (x, y, z)
+ real (kind = 8) :: f3
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ !$omp declare variant (f1) match (user={condition(0)},construct={parallel})
+ f3 = 0.0
+ end function
+
+ function f4 (x, y, z)
+ real (kind = 8) :: f4
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ !$omp declare variant (f1) match (construct={parallel},user={condition(score(1):1)})
+ f4 = 0.0
+ end function
+
+ function f5 (x, y, z)
+ real (kind = 8) :: f5
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ f5 = 0.0
+ end function
+
+ function f6 (x, y, z)
+ real (kind = 8) :: f6
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ !$omp declare variant (f5) match (user={condition(0)}) ! { dg-error "'f5' used as a variant with incompatible 'construct' selector sets" }
+ f6 = 0.0
+ end function
+
+ function f7 (x, y, z)
+ real (kind = 8) :: f7
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ !$omp declare variant (f5) match (construct={parallel},user={condition(score(1):1)})
+ f7 = 0.0
+ end function
+
+ function f8 (x, y, z)
+ real (kind = 8) :: f8
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ f8 = 0.0
+ end function
+
+ function f9 (x, y, z)
+ real (kind = 8) :: f9
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ !$omp declare variant (f8) match (user={condition(0)},construct={do}) ! { dg-error "'f8' used as a variant with incompatible 'construct' selector sets" }
+ f9 = 0.0
+ end function
+
+ function f10 (x, y, z)
+ real (kind = 8) :: f10
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ !$omp declare variant (f8) match (user={condition(1)})
+ f10 = 0.0
+ end function
+
+ function f11 (x, y, z)
+ real (kind = 8) :: f11
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ f11 = 0.0
+ end function
+
+ function f12 (x, y, z)
+ real (kind = 8) :: f12
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ !$omp declare variant (f11) match (construct={target,teams,parallel,do}) ! { dg-error "'f11' used as a variant with incompatible 'construct' selector sets" }
+ f12 = 0.0
+ end function
+
+ function f13 (x, y, z)
+ real (kind = 8) :: f13
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ !$omp declare variant (f11) match (user={condition(score(1):1)},construct={target,teams,parallel,do}) ! { dg-error "'f11' used as a variant with incompatible 'construct' selector sets" }
+ f13 = 0.0
+ end function
+
+ function f14 (x, y, z)
+ real (kind = 8) :: f14
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ !$omp declare variant (f11) match (implementation={vendor(gnu)},construct={target,teams,parallel}) ! { dg-error "'f11' used as a variant with incompatible 'construct' selector sets" }
+ f14 = 0.0
+ end function
+
+ function f15 (x, y, z)
+ real (kind = 8) :: f15
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ !$omp declare variant (f11) match (device={kind(any)},construct={teams,parallel})
+ f15 = 0.0
+ end function
+
+ function f16 (x, y, z)
+ real (kind = 8) :: f16
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ f16 = 0.0
+ end function
+
+ function f17 (x, y, z)
+ real (kind = 8) :: f17
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ !$omp declare variant (f16) match (construct={teams,parallel}) ! { dg-error "'f16' used as a variant with incompatible 'construct' selector sets" }
+ f17 = 0.0
+ end function
+
+ function f18 (x, y, z)
+ real (kind = 8) :: f18
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ !$omp declare variant (f16) match(construct={teams,parallel,do})
+ f18 = 0.0
+ end function
+
+ function f19 (x, y, z)
+ real (kind = 8) :: f19
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ f19 = 0.0
+ end function
+
+ function f20 (x, y, z)
+ real (kind = 8) :: f20
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ !$omp declare variant (f19) match (construct={parallel}) ! { dg-error "'f19' used as a variant with incompatible 'construct' selector sets" }
+ f20 = 0.0
+ end function
+
+ function f21 (x, y, z)
+ real (kind = 8) :: f21
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ !$omp declare variant (f19) match (construct={do},implementation={vendor(gnu,llvm)})
+ f21 = 0.0
+ end function
+
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-7.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-7.f90
new file mode 100644
index 00000000000..1590a2a26f0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-7.f90
@@ -0,0 +1,93 @@
+! { dg-do compile { target i?86-*-* x86_64-*-* } }
+! { dg-additional-options "-mavx2" }
+
+module main
+ implicit none
+contains
+ function f1 (x, y, z)
+ integer, dimension(4) :: f1
+ real, dimension(4), intent(in) :: x, y
+ real, intent(out) :: z
+
+ f1 = x
+ end function
+
+ function f2 (x, y, z)
+ integer, dimension(8) :: f2
+ real, dimension(8), intent(in) :: x, y
+ real, intent(out) :: z
+
+ f2 = x
+ end function
+
+ function f3 (x, y, z)
+ integer, dimension(4) :: f3
+ real, dimension(4), intent(in) :: x, z
+ integer, intent(in) :: y
+
+ f3 = x
+ end function
+
+ integer function f4 (x, y, z)
+ real, intent(in) :: x, y
+ real, pointer, intent(out) :: z
+ !$omp declare variant (f1) match (construct={parallel,do,simd(simdlen(4),notinbranch,uniform(z),aligned(z:16))}) ! { dg-error "'f1' used as a variant with incompatible 'construct' selector sets" }
+ end function
+
+ integer function f5 (u, v, w)
+ real, intent(in) :: u, v
+ real, pointer, intent(out) :: w
+ !$omp declare variant (f1) match (construct={parallel,do,simd(uniform(w),simdlen(8*2-12),aligned(w:16),notinbranch)}) ! { dg-error "'f1' used as a variant with incompatible 'construct' selector sets" }
+ end function
+
+ integer function f6 (u, v, w)
+ real, intent(in) :: u, v
+ real, pointer, intent(out) :: w
+ !$omp declare variant (f1) match (construct={parallel,do,simd(linear(w),notinbranch,simdlen(4),aligned(w:16))}) ! { dg-error "'f1' used as a variant with incompatible 'construct' selector sets" }
+ end function
+
+ integer function f7 (u, v, w)
+ real, intent(in) :: u, v
+ real, pointer, intent(out) :: w
+ !$omp declare variant (f1) match (construct={parallel,do,simd(uniform(w),notinbranch,simdlen(4),aligned(w:8))}) ! { dg-error "'f1' used as a variant with incompatible 'construct' selector sets" }
+ end function
+
+ integer function f8 (u, v, w)
+ real, intent(in) :: u, v
+ real, pointer, intent(out) :: w
+ !$omp declare variant (f1) match (construct={parallel,do,simd(uniform(w),notinbranch,simdlen(4),aligned(w))})
+ end function
+
+ integer function f9 (x, y, z)
+ real, intent(in) :: x, y
+ real, pointer, intent(out) :: z
+ !$omp declare variant (f2) match (construct={do,simd(uniform(z),simdlen(8),notinbranch)}) ! { dg-error "'f2' used as a variant with incompatible 'construct' selector sets" }
+ end function
+
+ integer function f10 (x, y, q)
+ real, intent(in) :: x, y
+ real, pointer, intent(out) :: q
+ !$omp declare variant (f2) match (construct={do,simd(notinbranch,simdlen(2+2+4),uniform (q))}) ! { dg-error "'f2' used as a variant with incompatible 'construct' selector sets" }
+ end function
+
+ integer function f11 (x, y, z)
+ real, intent(in) :: x, y
+ real, pointer, intent(out) :: z
+ !$omp declare variant (f2) match (construct={do,simd(linear(z:2),simdlen(8),notinbranch)})
+ end function
+
+ integer function f12 (x, y)
+ integer, intent(in) :: x, y
+ !$omp declare variant (f3) match (construct={simd(simdlen(4),inbranch,linear(y:1))}) ! { dg-error "'f3' used as a variant with incompatible 'construct' selector sets" }
+ end function
+
+ integer function f13 (x, q)
+ integer, intent(in) :: x, q
+ !$omp declare variant (f3) match (construct={simd(inbranch, simdlen (5-1), linear (q:4-3))}) ! { dg-error "'f3' used as a variant with incompatible 'construct' selector sets" }
+ end function
+
+ integer function f14 (x, q)
+ integer, intent(in) :: x, q
+ !$omp declare variant (f3) match (construct={simd(inbranch,simdlen(4),linear(q:2))})
+ end function
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-8.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-8.f90
new file mode 100644
index 00000000000..c751489a5db
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-8.f90
@@ -0,0 +1,218 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-gimple" }
+
+program main
+ !$omp requires atomic_default_mem_order(seq_cst)
+ !$omp declare target to (test3)
+contains
+ subroutine f01 ()
+ end subroutine
+
+ subroutine f02 ()
+ !$omp declare variant (f01) match (user={condition(6 == 7)},implementation={vendor(gnu)})
+ end subroutine
+
+ subroutine f03 ()
+ end subroutine
+
+ subroutine f04 ()
+ !$omp declare variant (f03) match (user={condition(6 == 6)},implementation={atomic_default_mem_order(seq_cst)})
+ end subroutine
+
+ subroutine f05 ()
+ end subroutine
+
+ subroutine f06 ()
+ !$omp declare variant (f05) match (user={condition(1)},implementation={atomic_default_mem_order(relaxed)})
+ end subroutine
+
+ subroutine f07 ()
+ end subroutine
+
+ subroutine f08 ()
+ !$omp declare variant (f07) match (construct={parallel,do},device={kind("any")})
+ end subroutine
+
+ subroutine f09 ()
+ end subroutine
+
+ subroutine f10 ()
+ !$omp declare variant (f09) match (construct={parallel,do},implementation={vendor("gnu")})
+ end subroutine
+
+ subroutine f11 ()
+ end subroutine
+
+ subroutine f12 ()
+ !$omp declare variant (f11) match (construct={parallel,do})
+ end subroutine
+
+ subroutine f13 ()
+ end subroutine
+
+ subroutine f14 ()
+ !$omp declare variant (f13) match (construct={parallel,do})
+ end subroutine
+
+ subroutine f15 ()
+ !$omp declare target to (f13, f14)
+ end subroutine
+
+ subroutine f16 ()
+ !$omp declare variant (f15) match (implementation={vendor(llvm)})
+ end subroutine
+
+ subroutine f17 ()
+ end subroutine
+
+ subroutine f18 ()
+ !$omp declare variant (f17) match (construct={target,parallel})
+ end subroutine
+
+ subroutine f19 ()
+ end subroutine
+
+ subroutine f20 ()
+ !$omp declare variant (f19) match (construct={target,parallel})
+ end subroutine
+
+ subroutine f22 ()
+ !$omp declare variant (f21) match (construct={teams,parallel})
+ end subroutine
+
+ subroutine f23 ()
+ end subroutine
+
+ subroutine f24 ()
+ !$omp declare variant (f23) match (construct={teams,parallel,do})
+ end subroutine
+
+ subroutine f25 ()
+ end subroutine
+
+ subroutine f27 ()
+ end subroutine
+
+ subroutine f28 ()
+ !$omp declare variant (f27) match (construct={teams,parallel,do})
+ end subroutine
+
+ subroutine f30 ()
+ !$omp declare variant (f29) match (implementation={vendor(gnu)})
+ end subroutine
+
+ subroutine f31 ()
+ end subroutine
+
+ subroutine f32 ()
+ !$omp declare variant (f31) match (construct={teams,parallel,do})
+ end subroutine
+
+ subroutine f33 ()
+ end subroutine
+
+ subroutine f34 ()
+ !$omp declare variant (f33) match (device={kind("any\0any")}) ! { dg-warning "unknown property '.any..0any.' of 'kind' selector" }
+ end subroutine
+
+ subroutine f35 ()
+ end subroutine
+
+ subroutine f36 ()
+ !$omp declare variant (f35) match (implementation={vendor("gnu\0")}) ! { dg-warning "unknown property '.gnu..0.' of 'vendor' selector" }
+ end subroutine
+
+ subroutine test1 ()
+ integer :: i
+
+ call f02 () ! { dg-final { scan-tree-dump-times "f02 \\\(\\\);" 1 "gimple" } }
+ call f04 () ! { dg-final { scan-tree-dump-times "f03 \\\(\\\);" 1 "gimple" } }
+ call f06 () ! { dg-final { scan-tree-dump-times "f06 \\\(\\\);" 1 "gimple" } }
+
+ !$omp parallel
+ !$omp do
+ do i = 1, 2
+ call f08 () ! { dg-final { scan-tree-dump-times "f07 \\\(\\\);" 1 "gimple" } }
+ end do
+ !$omp end do
+ !$omp end parallel
+
+ !$omp parallel do
+ do i = 1, 2
+ call f10 () ! { dg-final { scan-tree-dump-times "f09 \\\(\\\);" 1 "gimple" } }
+ end do
+ !$omp end parallel do
+
+ !$omp do
+ do i = 1, 2
+ !$omp parallel
+ call f12 () ! { dg-final { scan-tree-dump-times "f12 \\\(\\\);" 1 "gimple" } }
+ !$omp end parallel
+ end do
+ !$omp end do
+
+ !$omp parallel
+ !$omp target
+ !$omp do
+ do i = 1, 2
+ call f14 () ! { dg-final { scan-tree-dump-times "f14 \\\(\\\);" 1 "gimple" } }
+ end do
+ !$omp end do
+ !$omp end target
+ !$omp end parallel
+
+ call f16 () ! { dg-final { scan-tree-dump-times "f16 \\\(\\\);" 1 "gimple" } }
+ call f34 () ! { dg-final { scan-tree-dump-times "f34 \\\(\\\);" 1 "gimple" } }
+ call f36 () ! { dg-final { scan-tree-dump-times "f36 \\\(\\\);" 1 "gimple" } }
+ end subroutine
+
+ subroutine test2 ()
+ ! OpenMP 5.0 specifies that the 'target' trait should be added for
+ ! functions within a declare target block, but Fortran does not have
+ ! the notion of a declare target _block_, so the variant is not used here.
+ ! This may change in later versions of OpenMP.
+
+ !$omp declare target
+ !$omp parallel
+ call f18 () ! { dg-final { scan-tree-dump-times "f18 \\\(\\\);" 1 "gimple" } }
+ !$omp end parallel
+ end subroutine
+
+ subroutine test3 ()
+ ! In the C version, this test was used to check that the
+ ! 'declare target to' form of the directive did not result in the variant
+ ! being used.
+ !$omp parallel
+ call f20 () ! { dg-final { scan-tree-dump-times "f20 \\\(\\\);" 1 "gimple" } }
+ !$omp end parallel
+ end subroutine
+
+ subroutine f21 ()
+ integer :: i
+ !$omp do
+ do i = 1, 2
+ call f24 () ! { dg-final { scan-tree-dump-times "f23 \\\(\\\);" 1 "gimple" } }
+ end do
+ !$omp end do
+ end subroutine
+
+ subroutine f26 ()
+ !$omp declare variant (f25) match (construct={teams,parallel})
+
+ integer :: i
+ !$omp do
+ do i = 1, 2
+ call f28 () ! { dg-final { scan-tree-dump-times "f28 \\\(\\\);" 1 "gimple" } }
+ end do
+ !$omp end do
+ end subroutine
+
+ subroutine f29 ()
+ integer :: i
+ !$omp do
+ do i = 1, 2
+ call f32 () ! { dg-final { scan-tree-dump-times "f32 \\\(\\\);" 1 "gimple" } }
+ end do
+ !$omp end do
+ end subroutine
+end program
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-9.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-9.f90
new file mode 100644
index 00000000000..ebd066609f3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-9.f90
@@ -0,0 +1,58 @@
+! { dg-do compile }
+! { dg-additional-options "-cpp -fdump-tree-gimple" }
+! { dg-additional-options "-mno-sse3" { target { i?86-*-* x86_64-*-* } } }
+
+program main
+ implicit none
+contains
+ subroutine f01 ()
+ end subroutine
+ subroutine f02 ()
+ !$omp declare variant (f01) match (device={isa("avx512f",avx512bw)})
+ end subroutine
+ subroutine f05 ()
+ end subroutine
+ subroutine f06 ()
+ !$omp declare variant (f05) match (device={kind(gpu)})
+ end subroutine
+ subroutine f07 ()
+ end subroutine
+ subroutine f08 ()
+ !$omp declare variant (f07) match (device={kind("cpu")})
+ end subroutine
+ subroutine f09 ()
+ end subroutine
+ subroutine f10 ()
+ !$omp declare variant (f09) match (device={isa(sm_35)})
+ end subroutine
+ subroutine f11 ()
+ end subroutine
+ subroutine f12 ()
+ !$omp declare variant (f11) match (device={arch(nvptx)})
+ end subroutine
+ subroutine f13 ()
+ end subroutine
+ subroutine f14 ()
+ !$omp declare variant (f13) match (device={arch("i386"),isa(sse4)})
+ end subroutine
+ subroutine f17 ()
+ end subroutine
+ subroutine f18 ()
+ !$omp declare variant (f17) match (device={kind("any","fpga")})
+ end subroutine
+
+ subroutine test1 ()
+ integer :: i;
+ call f02 () ! { dg-final { scan-tree-dump-times "f02 \\\(\\\);" 1 "gimple" } }
+ call f14 () ! { dg-final { scan-tree-dump-times "f14 \\\(\\\);" 1 "gimple" } }
+ call f18 () ! { dg-final { scan-tree-dump-times "f18 \\\(\\\);" 1 "gimple" } }
+ end subroutine
+
+ subroutine test3 ()
+ call f06 () ! { dg-final { scan-tree-dump-times "f06 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* amdgcn*-*-* } } } } }
+ call f08 () ! { dg-final { scan-tree-dump-times "f07 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* amdgcn*-*-* } } } } }
+ call f10 () ! { dg-final { scan-tree-dump-times "f10 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* amdgcn*-*-* } } } } }
+ call f12 () ! { dg-final { scan-tree-dump-times "f12 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* } } } } }
+ ! { dg-final { scan-tree-dump-times "f11 \\\(\\\);" 1 "gimple" { target { nvptx*-*-* } } } }
+ end subroutine
+end program
diff --git a/libgomp/testsuite/libgomp.fortran/declare-variant-1.f90 b/libgomp/testsuite/libgomp.fortran/declare-variant-1.f90
new file mode 100644
index 00000000000..e6f69dccb49
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/declare-variant-1.f90
@@ -0,0 +1,33 @@
+! { dg-do run }
+
+program main
+ implicit none
+
+ integer :: v
+ !$omp target map(from:v)
+ v = on ()
+ !$omp end target
+
+ select case (v)
+ case default
+ write (*,*) "Host fallback or unknown offloading"
+ case (1)
+ write (*,*) "Offloading to NVidia PTX"
+ case (2)
+ write (*,*) "Offloading to AMD GCN"
+ end select
+contains
+ integer function on_nvptx ()
+ on_nvptx = 1
+ end function
+
+ integer function on_gcn ()
+ on_gcn = 2
+ end function
+
+ integer function on ()
+ !$omp declare variant (on_nvptx) match(construct={target},device={arch(nvptx)})
+ !$omp declare variant (on_gcn) match(construct={target},device={arch(gcn)})
+ on = 0
+ end function
+end program
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2021-10-14 16:19 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-10-14 16:19 [gcc r12-4409] openmp, fortran: Add support for OpenMP declare variant directive in Fortran Kwok Yeung
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).