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.
This commit is contained in:
Kwok Cheung Yeung
parent
73f34f4d02
commit
724ee5a009
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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,
|
||||
|
||||
@ -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 *);
|
||||
|
||||
@ -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);
|
||||
|
||||
@ -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)
|
||||
{
|
||||
|
||||
@ -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;
|
||||
|
||||
|
||||
@ -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);
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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));
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
@ -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 *);
|
||||
|
||||
|
||||
@ -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;
|
||||
}
|
||||
|
||||
@ -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 *);
|
||||
|
||||
93
gcc/testsuite/gfortran.dg/gomp/declare-variant-1.f90
Normal file
93
gcc/testsuite/gfortran.dg/gomp/declare-variant-1.f90
Normal file
@ -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
|
||||
97
gcc/testsuite/gfortran.dg/gomp/declare-variant-10.f90
Normal file
97
gcc/testsuite/gfortran.dg/gomp/declare-variant-10.f90
Normal file
@ -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
|
||||
|
||||
134
gcc/testsuite/gfortran.dg/gomp/declare-variant-11.f90
Normal file
134
gcc/testsuite/gfortran.dg/gomp/declare-variant-11.f90
Normal file
@ -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
|
||||
159
gcc/testsuite/gfortran.dg/gomp/declare-variant-12.f90
Normal file
159
gcc/testsuite/gfortran.dg/gomp/declare-variant-12.f90
Normal file
@ -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
|
||||
|
||||
48
gcc/testsuite/gfortran.dg/gomp/declare-variant-13.f90
Normal file
48
gcc/testsuite/gfortran.dg/gomp/declare-variant-13.f90
Normal file
@ -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
|
||||
49
gcc/testsuite/gfortran.dg/gomp/declare-variant-14.f90
Normal file
49
gcc/testsuite/gfortran.dg/gomp/declare-variant-14.f90
Normal file
@ -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
|
||||
24
gcc/testsuite/gfortran.dg/gomp/declare-variant-15.f90
Normal file
24
gcc/testsuite/gfortran.dg/gomp/declare-variant-15.f90
Normal file
@ -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
|
||||
24
gcc/testsuite/gfortran.dg/gomp/declare-variant-16.f90
Normal file
24
gcc/testsuite/gfortran.dg/gomp/declare-variant-16.f90
Normal file
@ -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
|
||||
17
gcc/testsuite/gfortran.dg/gomp/declare-variant-17.f90
Normal file
17
gcc/testsuite/gfortran.dg/gomp/declare-variant-17.f90
Normal file
@ -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
|
||||
17
gcc/testsuite/gfortran.dg/gomp/declare-variant-18.f90
Normal file
17
gcc/testsuite/gfortran.dg/gomp/declare-variant-18.f90
Normal file
@ -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
|
||||
49
gcc/testsuite/gfortran.dg/gomp/declare-variant-19.f90
Normal file
49
gcc/testsuite/gfortran.dg/gomp/declare-variant-19.f90
Normal file
@ -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
|
||||
197
gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90
Normal file
197
gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90
Normal file
@ -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
|
||||
53
gcc/testsuite/gfortran.dg/gomp/declare-variant-2a.f90
Normal file
53
gcc/testsuite/gfortran.dg/gomp/declare-variant-2a.f90
Normal file
@ -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
|
||||
237
gcc/testsuite/gfortran.dg/gomp/declare-variant-3.f90
Normal file
237
gcc/testsuite/gfortran.dg/gomp/declare-variant-3.f90
Normal file
@ -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
|
||||
62
gcc/testsuite/gfortran.dg/gomp/declare-variant-4.f90
Normal file
62
gcc/testsuite/gfortran.dg/gomp/declare-variant-4.f90
Normal file
@ -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
|
||||
75
gcc/testsuite/gfortran.dg/gomp/declare-variant-5.f90
Normal file
75
gcc/testsuite/gfortran.dg/gomp/declare-variant-5.f90
Normal file
@ -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
|
||||
188
gcc/testsuite/gfortran.dg/gomp/declare-variant-6.f90
Normal file
188
gcc/testsuite/gfortran.dg/gomp/declare-variant-6.f90
Normal file
@ -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
|
||||
93
gcc/testsuite/gfortran.dg/gomp/declare-variant-7.f90
Normal file
93
gcc/testsuite/gfortran.dg/gomp/declare-variant-7.f90
Normal file
@ -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
|
||||
218
gcc/testsuite/gfortran.dg/gomp/declare-variant-8.f90
Normal file
218
gcc/testsuite/gfortran.dg/gomp/declare-variant-8.f90
Normal file
@ -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
|
||||
58
gcc/testsuite/gfortran.dg/gomp/declare-variant-9.f90
Normal file
58
gcc/testsuite/gfortran.dg/gomp/declare-variant-9.f90
Normal file
@ -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
|
||||
33
libgomp/testsuite/libgomp.fortran/declare-variant-1.f90
Normal file
33
libgomp/testsuite/libgomp.fortran/declare-variant-1.f90
Normal file
@ -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
|
||||
Loading…
Reference in New Issue
Block a user