openmp, fortran: Add support for declare variant in Fortran
Commit Message
Hello
This patch adds support for the OpenMP 'declare variant' directive in
Fortran (C/C++ support is already present). For most part, this is a
straightforward port of the C frontend code. I have ported all the
c-c++-common/gomp/declare-variant-*.c tests to Fortran in
gfortran.dg/gomp/, skipping over any tests involving inline assembly. I
have also ported libgomp.c/target-42.c to Fortran as
libgomp.fortran/declare-variant-1.f90.
I have moved the c_omp_check_context_selector and
c_omp_mark_declare_variant functions from c-family/c-omp.c into
omp-general.c and removed the 'c_' prefix, as these functions can be
reused for Fortran.
Since the Fortran FE parses code first before translating it into tree
form, fatal parser errors in a source file will result in errors in the
same source file that are detected at translation time not being
displayed (as compilation does not reach that stage). I have therefore
separated out the translation errors in declare-variant-2.f90 into
declare-variant-2a.f90.
In secion 2.3.1 of the OpenMP 5.0 spec, it says:
3. For functions within a declare target block, the target trait is
added to the beginning of the set...
But OpenMP in Fortran doesn't have the notion of a declare target
_block_ (i.e. the #pragma omp declare target/#pragma omp end declare
target form), only the !$omp declare target (extended-list)/[clause]
form (which C/C++ also has). The C FE differentiates between the two (it
applies an 'omp declare target block' attribute for the first, an 'omp
declare target' for the second) but only the first matches against the
'target' construct in a context selector. I opted to match against 'omp
declare target' for Fortran only, otherwise this functionality won't get
exercised in Fortran at all. This difference is tested in test3 of
declare-variant-8.f90, which I have XFAILed for now.
The Fortran 'declare variant' directive can also optionally take the
name of the base procedure - this is implemented by moving any 'declare
variant' directives with a matching base name in the parent namespaces
of a function into the function namespace itself, such that at
translation time it appears as if the directive was placed in the base
procedure. This is tested in declare-variant-15.f90.
Bootstrapped on x86_64, and the gfortran testsuite and libgomp.fortran
tests run with no regressions. Okay for trunk?
Thanks
Kwok Yeung
commit 317d69154cc91d2f6e7fed6c054dc2b3852bf604
Author: Kwok Cheung Yeung <kcy@codesourcery.com>
Date: Wed Oct 6 04:16:55 2021 -0700
openmp, fortran: Add support for OpenMP declare variant directive in Fortran
2021-10-05 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_create_function_decl): Move relevant
'declare variant' declarations into base function namespace. 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/
* gimplify.c (omp_construct_selector_matches): Match target construct
against 'omp declare target' attribute for Fortran.
* 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-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.
Comments
On Wed, Oct 06, 2021 at 12:39:01PM +0100, Kwok Cheung Yeung wrote:
> In secion 2.3.1 of the OpenMP 5.0 spec, it says:
>
> 3. For functions within a declare target block, the target trait is added to
> the beginning of the set...
>
> But OpenMP in Fortran doesn't have the notion of a declare target _block_
> (i.e. the #pragma omp declare target/#pragma omp end declare target form),
> only the !$omp declare target (extended-list)/[clause] form (which C/C++
> also has). The C FE differentiates between the two (it applies an 'omp
> declare target block' attribute for the first, an 'omp declare target' for
> the second) but only the first matches against the 'target' construct in a
> context selector. I opted to match against 'omp declare target' for Fortran
> only, otherwise this functionality won't get exercised in Fortran at all.
> This difference is tested in test3 of declare-variant-8.f90, which I have
> XFAILed for now.
Let me answer this separately. The 5.0 wording I believe means it doesn't
apply to Fortran at all. This has been noticed in 5.1 and changed to:
For device routines, the target trait is added to the beginning of the set...
which was actually far worse for the LLVM/ICC way of doing things (see
below), whether something is a device routine is determined either through explicit
#pragma omp {,begin} declare target
...
#pragma omp end declare target
block which has the advantage that it is known at compile time during
parsing (that is the reason why the 5.0 wording was written that way),
or through explicit or implicit to clauses on explicit declare target
(which can appear before the call site to the function or after it),
or during the implicit declare target to propagation that is done even
later.
Now, in 5.2 some language committee members wanted to make the presence of
absence of target in the construct selector a dynamic property, but that
would make all of the score computations dynamic as well, the presence or
absence of target in the construct selector affects what bit positions other
selectors get during the score computation.
For procedures that are determined to be target function variants by
a declare target directive, the target trait is added to the beginning of the set...
So, in the 5.2 wording and the current GCC implementation of offloading,
the presence or absence of target in the construct set or everything it
depends on needs to be deferred until omp_discover_implicit_declare_target
(i.e. before gimplification) for functions that aren't going to be marked
as "declare target to", and till after IPA for functions that are marked
that way (in that case, the host copy will not get target in the constructor
set and the offloading lto1 copies will get it).
As has been said multiple times, the way we do it in GCC is different from
the way LLVM/ICC etc. do it; they preprocess and parse, analyze etc. the
source code multiple times, once for each offloading target, trust user
isn't doing anything nasty and that e.g. preprocessor macros will not make
the host and offloading targets structures used during mapping different,
different target regions etc. And the way they are implementing is then
shown in the amount of features that assume their way as the only way,
e.g. about begin declare variant ... end declare variant allowing
effectively not to parse what is in between those, which assumes that pretty
much all the static conditions can be resolved already during the parsing,
which is rarely the case for GCC.
So, perhaps we'll need one day to reconsider what we do and we could say
preprocess just once, but parse multiple times if we determine we need to
offload, and at that point questions like "is this the host or offloading
target variant of declare target?" can be answered already during that parsing.
E.g. C++ FE isn't that far from it, it creates the array of lexical tokens
and then parses those tokens (but I think from time to time modifies the
token array, e.g. the purged_p or error_reported bits).
The C FE doesn't do that.
And users can supply - as the source filename and have the source read from
stdin, at which time there is no file to parse again.
So, for this question, my preference would be for now to implement the 5.0
semantics and never add target to construct set for Fortran unless in
explicit !$omp target body.
When we implement the 5.1 semantics, that would basically mean we have to
defer everything related to target construct in the set outside of explicit
target until gimplification time (after the implicit declare target
discovery), though note at least the C/C++ FEs decide everything declare
variant related at gimplification time only (perhaps to be changed in the
future).
Jakub
On Wed, Oct 06, 2021 at 12:39:01PM +0100, Kwok Cheung Yeung wrote:
> --- a/gcc/gimplify.c
> +++ b/gcc/gimplify.c
> @@ -11599,8 +11599,11 @@ omp_construct_selector_matches (enum tree_code *constructs, int nconstructs,
> }
> }
> if (!target_seen
> - && lookup_attribute ("omp declare target block",
> - DECL_ATTRIBUTES (current_function_decl)))
> + && (lookup_attribute ("omp declare target block",
> + DECL_ATTRIBUTES (current_function_decl))
> + || (lang_GNU_Fortran ()
> + && lookup_attribute ("omp declare target",
> + DECL_ATTRIBUTES (current_function_decl)))))
> {
> if (scores)
> codes.safe_push (OMP_TARGET);
So, as I wrote in the other mail, my preference would be to drop this hunk
and adjust testcases appropriately (perhaps with a comment).
The 5.1 way will then be different for all 3 languages and 5.2 way as well.
> + 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)))
This is a little bit strange but if all identifiers from Fortran FE behave
that way and differently from C/C++ FEs, I guess we can live with that
(multiple occurrences thereof).
> + DECL_ATTRIBUTES (base_fn_decl)
> + = tree_cons (
> + get_identifier ("omp declare variant base"),
> + build_tree_list (gfc_get_symbol_decl (variant_proc_sym),
> + set_selectors),
> + DECL_ATTRIBUTES (base_fn_decl));
Perhaps that is just my private coding convention preference, but I really
don't like these calls with function (
on one line and less indented arguments on another one. I'd find it more
readable to do use temporaries where possible,
tree id = get_identifier ("omp declare variant base");
tree var = gfc_get_symbol_decl (variant_proc_sym);
DECL_ATTRIBUTES (base_fn_decl)
= tree_cons (id, build_tree_list (var, set_selectors),
DECL_ATTRIBUTES (base_fn_decl));
is IMHO more radable and fits on fewer lines even.
Other than that the patch looks mostly good, what I miss in the testcases
though is Fortran specific stuff, e.g. I couldn't find a single testcase
that uses the
!$omp declare variant (procname:variantprocname) match (construct={parallel})
syntax and couldn't find testcase coverage or resolving of the Fortran
specific declare variant restrictions.
See OpenMP 5.0 [60:1-12], which includes
base-proc-name must not be a generic name, procedure pointer, or entry name.
and
If base-proc-name is omitted then the declare variant directive must appear in the
specification part of a subroutine subprogram or a function subprogram.
etc. So unless I've completely missed that in the patch somewhere, please
try to add new testcases (i.e. with no c-c++-common counterparts) that test
all those restrictions in there, have one !$omp declare variant with
base-proc-name that is a generic name and dg-error for it, another one
for procedure pointer, another one for entry name, another one for
!$omp declare variant with base-proc-name omitted that appears where it
isn't allowed, some !$omp declare variant (both with and without
proc-base-name) that appears e.g. in execution part, etc.
My Fortran knowledge is rusty, but I hope Tobias could help there if needed,
and if some of the restrictions make no sense, look at what has changed in
5.1 or 5.2 current state if it hasn't been clarified.
Jakub
On 06/10/2021 4:36 pm, Jakub Jelinek wrote:
> On Wed, Oct 06, 2021 at 12:39:01PM +0100, Kwok Cheung Yeung wrote:
>> --- a/gcc/gimplify.c
>> +++ b/gcc/gimplify.c
>> @@ -11599,8 +11599,11 @@ omp_construct_selector_matches (enum tree_code *constructs, int nconstructs,
>> }
>> }
>> if (!target_seen
>> - && lookup_attribute ("omp declare target block",
>> - DECL_ATTRIBUTES (current_function_decl)))
>> + && (lookup_attribute ("omp declare target block",
>> + DECL_ATTRIBUTES (current_function_decl))
>> + || (lang_GNU_Fortran ()
>> + && lookup_attribute ("omp declare target",
>> + DECL_ATTRIBUTES (current_function_decl)))))
>> {
>> if (scores)
>> codes.safe_push (OMP_TARGET);
>
> So, as I wrote in the other mail, my preference would be to drop this hunk
> and adjust testcases appropriately (perhaps with a comment).
> The 5.1 way will then be different for all 3 languages and 5.2 way as well.
>
I have now dropped this. This affects test2 in
gfortran.dg/gomp/declare-variant-8.f90, which I have added a comment to.
>> + DECL_ATTRIBUTES (base_fn_decl)
>> + = tree_cons (
>> + get_identifier ("omp declare variant base"),
>> + build_tree_list (gfc_get_symbol_decl (variant_proc_sym),
>> + set_selectors),
>> + DECL_ATTRIBUTES (base_fn_decl));
>
> Perhaps that is just my private coding convention preference, but I really
> don't like these calls with function (
> on one line and less indented arguments on another one. I'd find it more
> readable to do use temporaries where possible,
> tree id = get_identifier ("omp declare variant base");
> tree var = gfc_get_symbol_decl (variant_proc_sym);
> DECL_ATTRIBUTES (base_fn_decl)
> = tree_cons (id, build_tree_list (var, set_selectors),
> DECL_ATTRIBUTES (base_fn_decl));
> is IMHO more radable and fits on fewer lines even.
>
Done.
> Other than that the patch looks mostly good, what I miss in the testcases
> though is Fortran specific stuff, e.g. I couldn't find a single testcase
> that uses the
> !$omp declare variant (procname:variantprocname) match (construct={parallel})
> syntax and couldn't find testcase coverage or resolving of the Fortran
> specific declare variant restrictions.
> See OpenMP 5.0 [60:1-12], which includes
> base-proc-name must not be a generic name, procedure pointer, or entry name.
> and
> If base-proc-name is omitted then the declare variant directive must appear in the
> specification part of a subroutine subprogram or a function subprogram.
> etc. So unless I've completely missed that in the patch somewhere, please
> try to add new testcases (i.e. with no c-c++-common counterparts) that test
> all those restrictions in there, have one !$omp declare variant with
> base-proc-name that is a generic name and dg-error for it, another one
> for procedure pointer, another one for entry name, another one for
> !$omp declare variant with base-proc-name omitted that appears where it
> isn't allowed, some !$omp declare variant (both with and without
> proc-base-name) that appears e.g. in execution part, etc.
> My Fortran knowledge is rusty, but I hope Tobias could help there if needed,
> and if some of the restrictions make no sense, look at what has changed in
> 5.1 or 5.2 current state if it hasn't been clarified.
I have added Fortran-specific tests as
gfortran.dg/gomp/declare-variant-15.f90 to declare-variant-19.f90.
The parent namespace scanning has now been moved to
gfc_trans_omp_declare_variant (to avoid having a large chunk of
OpenMP-specific code in generic code), with some additional checking in
place. A call to gfc_trans_omp_declare_variant has been added to
gfc_get_extern_function_decl (otherwise the variants would not be
applied to external procedures that are not defined yet).
Kwok
From ab03cf08c6ee4a0a6323189313cae911483a2257 Mon Sep 17 00:00:00 2001
From: Kwok Cheung Yeung <kcy@codesourcery.com>
Date: Wed, 13 Oct 2021 22:39:20 +0100
Subject: [PATCH] openmp, fortran: Add support for OpenMP declare variant
directive in Fortran
2021-10-13 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.
---
gcc/c-family/c-omp.c | 137 -----
gcc/c/c-parser.c | 4 +-
gcc/cp/decl.c | 2 +-
gcc/cp/parser.c | 2 +-
gcc/fortran/gfortran.h | 73 ++-
gcc/fortran/match.h | 1 +
gcc/fortran/openmp.c | 513 +++++++++++++++++-
gcc/fortran/parse.c | 26 +
gcc/fortran/symbol.c | 1 +
gcc/fortran/trans-decl.c | 16 +-
gcc/fortran/trans-openmp.c | 205 +++++++
gcc/fortran/trans-stmt.h | 1 +
gcc/omp-general.c | 143 ++++-
gcc/omp-general.h | 3 +
.../gfortran.dg/gomp/declare-variant-1.f90 | 93 ++++
.../gfortran.dg/gomp/declare-variant-10.f90 | 97 ++++
.../gfortran.dg/gomp/declare-variant-11.f90 | 134 +++++
.../gfortran.dg/gomp/declare-variant-12.f90 | 159 ++++++
.../gfortran.dg/gomp/declare-variant-13.f90 | 48 ++
.../gfortran.dg/gomp/declare-variant-14.f90 | 49 ++
.../gfortran.dg/gomp/declare-variant-15.f90 | 24 +
.../gfortran.dg/gomp/declare-variant-16.f90 | 24 +
.../gfortran.dg/gomp/declare-variant-17.f90 | 17 +
.../gfortran.dg/gomp/declare-variant-18.f90 | 17 +
.../gfortran.dg/gomp/declare-variant-19.f90 | 49 ++
.../gfortran.dg/gomp/declare-variant-2.f90 | 197 +++++++
.../gfortran.dg/gomp/declare-variant-2a.f90 | 53 ++
.../gfortran.dg/gomp/declare-variant-3.f90 | 237 ++++++++
.../gfortran.dg/gomp/declare-variant-4.f90 | 62 +++
.../gfortran.dg/gomp/declare-variant-5.f90 | 75 +++
.../gfortran.dg/gomp/declare-variant-6.f90 | 188 +++++++
.../gfortran.dg/gomp/declare-variant-7.f90 | 93 ++++
.../gfortran.dg/gomp/declare-variant-8.f90 | 218 ++++++++
.../gfortran.dg/gomp/declare-variant-9.f90 | 58 ++
.../libgomp.fortran/declare-variant-1.f90 | 33 ++
35 files changed, 2904 insertions(+), 148 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-variant-1.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-variant-10.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-variant-11.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-variant-12.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-variant-13.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-variant-14.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-variant-15.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-variant-16.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-variant-17.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-variant-18.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-variant-19.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-variant-2a.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-variant-3.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-variant-4.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-variant-5.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-variant-6.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-variant-7.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-variant-8.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/declare-variant-9.f90
create mode 100644 libgomp/testsuite/libgomp.fortran/declare-variant-1.f90
diff --git a/gcc/c-family/c-omp.c b/gcc/c-family/c-omp.c
index d8b98552fb9..17578f9b5a6 100644
--- a/gcc/c-family/c-omp.c
+++ b/gcc/c-family/c-omp.c
@@ -2909,143 +2909,6 @@ c_omp_predetermined_mapping (tree decl)
}
-/* Diagnose errors in an OpenMP context selector, return CTX if
- it is correct or error_mark_node otherwise. */
-
-tree
-c_omp_check_context_selector (location_t loc, tree ctx)
-{
- /* Each trait-set-selector-name can only be specified once.
- There are just 4 set names. */
- for (tree t1 = ctx; t1; t1 = TREE_CHAIN (t1))
- for (tree t2 = TREE_CHAIN (t1); t2; t2 = TREE_CHAIN (t2))
- if (TREE_PURPOSE (t1) == TREE_PURPOSE (t2))
- {
- error_at (loc, "selector set %qs specified more than once",
- IDENTIFIER_POINTER (TREE_PURPOSE (t1)));
- return error_mark_node;
- }
- for (tree t = ctx; t; t = TREE_CHAIN (t))
- {
- /* Each trait-selector-name can only be specified once. */
- if (list_length (TREE_VALUE (t)) < 5)
- {
- for (tree t1 = TREE_VALUE (t); t1; t1 = TREE_CHAIN (t1))
- for (tree t2 = TREE_CHAIN (t1); t2; t2 = TREE_CHAIN (t2))
- if (TREE_PURPOSE (t1) == TREE_PURPOSE (t2))
- {
- error_at (loc,
- "selector %qs specified more than once in set %qs",
- IDENTIFIER_POINTER (TREE_PURPOSE (t1)),
- IDENTIFIER_POINTER (TREE_PURPOSE (t)));
- return error_mark_node;
- }
- }
- else
- {
- hash_set<tree> pset;
- for (tree t1 = TREE_VALUE (t); t1; t1 = TREE_CHAIN (t1))
- if (pset.add (TREE_PURPOSE (t1)))
- {
- error_at (loc,
- "selector %qs specified more than once in set %qs",
- IDENTIFIER_POINTER (TREE_PURPOSE (t1)),
- IDENTIFIER_POINTER (TREE_PURPOSE (t)));
- return error_mark_node;
- }
- }
-
- static const char *const kind[] = {
- "host", "nohost", "cpu", "gpu", "fpga", "any", NULL };
- static const char *const vendor[] = {
- "amd", "arm", "bsc", "cray", "fujitsu", "gnu", "ibm", "intel",
- "llvm", "nvidia", "pgi", "ti", "unknown", NULL };
- static const char *const extension[] = { NULL };
- static const char *const atomic_default_mem_order[] = {
- "seq_cst", "relaxed", "acq_rel", NULL };
- struct known_properties { const char *set; const char *selector;
- const char *const *props; };
- known_properties props[] = {
- { "device", "kind", kind },
- { "implementation", "vendor", vendor },
- { "implementation", "extension", extension },
- { "implementation", "atomic_default_mem_order",
- atomic_default_mem_order } };
- for (tree t1 = TREE_VALUE (t); t1; t1 = TREE_CHAIN (t1))
- for (unsigned i = 0; i < ARRAY_SIZE (props); i++)
- if (!strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t1)),
- props[i].selector)
- && !strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)),
- props[i].set))
- for (tree t2 = TREE_VALUE (t1); t2; t2 = TREE_CHAIN (t2))
- for (unsigned j = 0; ; j++)
- {
- if (props[i].props[j] == NULL)
- {
- if (TREE_PURPOSE (t2)
- && !strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t2)),
- " score"))
- break;
- if (props[i].props == atomic_default_mem_order)
- {
- error_at (loc,
- "incorrect property %qs of %qs selector",
- IDENTIFIER_POINTER (TREE_PURPOSE (t2)),
- "atomic_default_mem_order");
- return error_mark_node;
- }
- else if (TREE_PURPOSE (t2))
- warning_at (loc, 0,
- "unknown property %qs of %qs selector",
- IDENTIFIER_POINTER (TREE_PURPOSE (t2)),
- props[i].selector);
- else
- warning_at (loc, 0,
- "unknown property %qE of %qs selector",
- TREE_VALUE (t2), props[i].selector);
- break;
- }
- else if (TREE_PURPOSE (t2) == NULL_TREE)
- {
- const char *str = TREE_STRING_POINTER (TREE_VALUE (t2));
- if (!strcmp (str, props[i].props[j])
- && ((size_t) TREE_STRING_LENGTH (TREE_VALUE (t2))
- == strlen (str) + 1))
- break;
- }
- else if (!strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t2)),
- props[i].props[j]))
- break;
- }
- }
- return ctx;
-}
-
-/* Register VARIANT as variant of some base function marked with
- #pragma omp declare variant. CONSTRUCT is corresponding construct
- selector set. */
-
-void
-c_omp_mark_declare_variant (location_t loc, tree variant, tree construct)
-{
- tree attr = lookup_attribute ("omp declare variant variant",
- DECL_ATTRIBUTES (variant));
- if (attr == NULL_TREE)
- {
- attr = tree_cons (get_identifier ("omp declare variant variant"),
- unshare_expr (construct),
- DECL_ATTRIBUTES (variant));
- DECL_ATTRIBUTES (variant) = attr;
- return;
- }
- if ((TREE_VALUE (attr) != NULL_TREE) != (construct != NULL_TREE)
- || (construct != NULL_TREE
- && omp_context_selector_set_compare ("construct", TREE_VALUE (attr),
- construct)))
- error_at (loc, "%qD used as a variant with incompatible %<construct%> "
- "selector sets", variant);
-}
-
/* For OpenACC, the OMP_CLAUSE_MAP_KIND of an OMP_CLAUSE_MAP is used internally
to distinguish clauses as seen by the user. Return the "friendly" clause
name for error messages etc., where possible. See also
diff --git a/gcc/c/c-parser.c b/gcc/c/c-parser.c
index 869a811ed90..80dd61d599e 100644
--- a/gcc/c/c-parser.c
+++ b/gcc/c/c-parser.c
@@ -21694,7 +21694,7 @@ c_finish_omp_declare_variant (c_parser *parser, tree fndecl, tree parms)
tree ctx = c_parser_omp_context_selector_specification (parser, parms);
if (ctx == error_mark_node)
goto fail;
- ctx = c_omp_check_context_selector (match_loc, ctx);
+ ctx = omp_check_context_selector (match_loc, ctx);
if (ctx != error_mark_node && variant != error_mark_node)
{
if (TREE_CODE (variant) != FUNCTION_DECL)
@@ -21724,7 +21724,7 @@ c_finish_omp_declare_variant (c_parser *parser, tree fndecl, tree parms)
{
C_DECL_USED (variant) = 1;
tree construct = omp_get_context_selector (ctx, "construct", NULL);
- c_omp_mark_declare_variant (match_loc, variant, construct);
+ omp_mark_declare_variant (match_loc, variant, construct);
if (omp_context_selector_matches (ctx))
{
tree attr
diff --git a/gcc/cp/decl.c b/gcc/cp/decl.c
index 561debe6a0e..242429d9ef4 100644
--- a/gcc/cp/decl.c
+++ b/gcc/cp/decl.c
@@ -7768,7 +7768,7 @@ omp_declare_variant_finalize_one (tree decl, tree attr)
else
{
tree construct = omp_get_context_selector (ctx, "construct", NULL);
- c_omp_mark_declare_variant (match_loc, variant, construct);
+ omp_mark_declare_variant (match_loc, variant, construct);
if (!omp_context_selector_matches (ctx))
return true;
TREE_PURPOSE (TREE_VALUE (attr)) = variant;
diff --git a/gcc/cp/parser.c b/gcc/cp/parser.c
index 0818d66be07..865778e4d30 100644
--- a/gcc/cp/parser.c
+++ b/gcc/cp/parser.c
@@ -45319,7 +45319,7 @@ cp_finish_omp_declare_variant (cp_parser *parser, cp_token *pragma_tok,
tree ctx = cp_parser_omp_context_selector_specification (parser, true);
if (ctx == error_mark_node)
goto fail;
- ctx = c_omp_check_context_selector (match_loc, ctx);
+ ctx = omp_check_context_selector (match_loc, ctx);
if (ctx != error_mark_node && variant != error_mark_node)
{
tree match_loc_node = maybe_wrap_with_location (integer_zero_node,
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index c25d1cca3a8..af01d2b29cf 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -239,7 +239,7 @@ enum gfc_statement
ST_OMP_DO_SIMD, ST_OMP_END_DO_SIMD, ST_OMP_PARALLEL_DO_SIMD,
ST_OMP_END_PARALLEL_DO_SIMD, ST_OMP_DECLARE_SIMD, ST_OMP_DECLARE_REDUCTION,
ST_OMP_TARGET, ST_OMP_END_TARGET, ST_OMP_TARGET_DATA, ST_OMP_END_TARGET_DATA,
- ST_OMP_TARGET_UPDATE, ST_OMP_DECLARE_TARGET,
+ ST_OMP_TARGET_UPDATE, ST_OMP_DECLARE_TARGET, ST_OMP_DECLARE_VARIANT,
ST_OMP_TEAMS, ST_OMP_END_TEAMS, ST_OMP_DISTRIBUTE, ST_OMP_END_DISTRIBUTE,
ST_OMP_DISTRIBUTE_SIMD, ST_OMP_END_DISTRIBUTE_SIMD,
ST_OMP_DISTRIBUTE_PARALLEL_DO, ST_OMP_END_DISTRIBUTE_PARALLEL_DO,
@@ -1554,6 +1554,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;
@@ -2023,6 +2090,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. */
@@ -3423,6 +3493,7 @@ bool gfc_omp_requires_add_clause (gfc_omp_requires_kind, const char *,
void gfc_check_omp_requires (gfc_namespace *, int);
void gfc_free_omp_clauses (gfc_omp_clauses *);
void gfc_free_oacc_declare_clauses (struct gfc_oacc_declare *);
+void gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list);
void gfc_free_omp_declare_simd (gfc_omp_declare_simd *);
void gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *);
void gfc_free_omp_udr (gfc_omp_udr *);
diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h
index 92fd127a57f..21e94f79d95 100644
--- a/gcc/fortran/match.h
+++ b/gcc/fortran/match.h
@@ -160,6 +160,7 @@ match gfc_match_omp_critical (void);
match gfc_match_omp_declare_reduction (void);
match gfc_match_omp_declare_simd (void);
match gfc_match_omp_declare_target (void);
+match gfc_match_omp_declare_variant (void);
match gfc_match_omp_depobj (void);
match gfc_match_omp_distribute (void);
match gfc_match_omp_distribute_parallel_do (void);
diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index 6a4ca2868f8..2a161f3304c 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -168,6 +168,70 @@ gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list)
}
}
+static void
+gfc_free_omp_trait_property_list (gfc_omp_trait_property *list)
+{
+ while (list)
+ {
+ gfc_omp_trait_property *current = list;
+ list = list->next;
+ switch (current->property_kind)
+ {
+ case CTX_PROPERTY_ID:
+ free (current->name);
+ break;
+ case CTX_PROPERTY_NAME_LIST:
+ if (current->is_name)
+ free (current->name);
+ break;
+ case CTX_PROPERTY_SIMD:
+ gfc_free_omp_clauses (current->clauses);
+ break;
+ default:
+ break;
+ }
+ free (current);
+ }
+}
+
+static void
+gfc_free_omp_selector_list (gfc_omp_selector *list)
+{
+ while (list)
+ {
+ gfc_omp_selector *current = list;
+ list = list->next;
+ gfc_free_omp_trait_property_list (current->properties);
+ free (current);
+ }
+}
+
+static void
+gfc_free_omp_set_selector_list (gfc_omp_set_selector *list)
+{
+ while (list)
+ {
+ gfc_omp_set_selector *current = list;
+ list = list->next;
+ gfc_free_omp_selector_list (current->trait_selectors);
+ free (current);
+ }
+}
+
+/* Free an !$omp declare variant construct list. */
+
+void
+gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list)
+{
+ while (list)
+ {
+ gfc_omp_declare_variant *current = list;
+ list = list->next;
+ gfc_free_omp_set_selector_list (current->set_selectors);
+ free (current);
+ }
+}
+
/* Free an !$omp declare reduction. */
void
@@ -1353,7 +1417,7 @@ gfc_match_dupl_atomic (bool not_dupl, const char *name)
static match
gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
bool first = true, bool needs_space = true,
- bool openacc = false)
+ bool openacc = false, bool context_selector = false)
{
bool error = false;
gfc_omp_clauses *c = gfc_get_omp_clauses ();
@@ -2843,7 +2907,9 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
}
end:
- if (error || gfc_match_omp_eos () != MATCH_YES)
+ if (error
+ || (context_selector && gfc_peek_ascii_char () != ')')
+ || (!context_selector && gfc_match_omp_eos () != MATCH_YES))
{
if (!gfc_error_flag_test ())
gfc_error ("Failed to match clause at %C");
@@ -4429,6 +4495,449 @@ cleanup:
}
+static const char *const omp_construct_selectors[] = {
+ "simd", "target", "teams", "parallel", "do", NULL };
+static const char *const omp_device_selectors[] = {
+ "kind", "isa", "arch", NULL };
+static const char *const omp_implementation_selectors[] = {
+ "vendor", "extension", "atomic_default_mem_order", "unified_address",
+ "unified_shared_memory", "dynamic_allocators", "reverse_offload", NULL };
+static const char *const omp_user_selectors[] = {
+ "condition", NULL };
+
+
+/* OpenMP 5.0:
+
+ trait-selector:
+ trait-selector-name[([trait-score:]trait-property[,trait-property[,...]])]
+
+ trait-score:
+ score(score-expression) */
+
+match
+gfc_match_omp_context_selector (gfc_omp_set_selector *oss)
+{
+ do
+ {
+ char selector[GFC_MAX_SYMBOL_LEN + 1];
+
+ if (gfc_match_name (selector) != MATCH_YES)
+ {
+ gfc_error ("expected trait selector name at %C");
+ return MATCH_ERROR;
+ }
+
+ gfc_omp_selector *os = gfc_get_omp_selector ();
+ os->trait_selector_name = XNEWVEC (char, strlen (selector) + 1);
+ strcpy (os->trait_selector_name, selector);
+ os->next = oss->trait_selectors;
+ oss->trait_selectors = os;
+
+ const char *const *selectors = NULL;
+ bool allow_score = true;
+ bool allow_user = false;
+ int property_limit = 0;
+ enum gfc_omp_trait_property_kind property_kind = CTX_PROPERTY_NONE;
+ switch (oss->trait_set_selector_name[0])
+ {
+ case 'c': /* construct */
+ selectors = omp_construct_selectors;
+ allow_score = false;
+ property_limit = 1;
+ property_kind = CTX_PROPERTY_SIMD;
+ break;
+ case 'd': /* device */
+ selectors = omp_device_selectors;
+ allow_score = false;
+ allow_user = true;
+ property_limit = 3;
+ property_kind = CTX_PROPERTY_NAME_LIST;
+ break;
+ case 'i': /* implementation */
+ selectors = omp_implementation_selectors;
+ allow_user = true;
+ property_limit = 3;
+ property_kind = CTX_PROPERTY_NAME_LIST;
+ break;
+ case 'u': /* user */
+ selectors = omp_user_selectors;
+ property_limit = 1;
+ property_kind = CTX_PROPERTY_EXPR;
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ for (int i = 0; ; i++)
+ {
+ if (selectors[i] == NULL)
+ {
+ if (allow_user)
+ {
+ property_kind = CTX_PROPERTY_USER;
+ break;
+ }
+ else
+ {
+ gfc_error ("selector '%s' not allowed for context selector "
+ "set '%s' at %C",
+ selector, oss->trait_set_selector_name);
+ return MATCH_ERROR;
+ }
+ }
+ if (i == property_limit)
+ property_kind = CTX_PROPERTY_NONE;
+ if (strcmp (selectors[i], selector) == 0)
+ break;
+ }
+ if (property_kind == CTX_PROPERTY_NAME_LIST
+ && oss->trait_set_selector_name[0] == 'i'
+ && strcmp (selector, "atomic_default_mem_order") == 0)
+ property_kind = CTX_PROPERTY_ID;
+
+ if (gfc_match (" (") == MATCH_YES)
+ {
+ if (property_kind == CTX_PROPERTY_NONE)
+ {
+ gfc_error ("selector '%s' does not accept any properties at %C",
+ selector);
+ return MATCH_ERROR;
+ }
+
+ if (allow_score && gfc_match (" score") == MATCH_YES)
+ {
+ if (gfc_match (" (") != MATCH_YES)
+ {
+ gfc_error ("expected '(' at %C");
+ return MATCH_ERROR;
+ }
+ if (gfc_match_expr (&os->score) != MATCH_YES
+ || !gfc_resolve_expr (os->score)
+ || os->score->ts.type != BT_INTEGER
+ || os->score->rank != 0)
+ {
+ gfc_error ("score argument must be constant integer "
+ "expression at %C");
+ return MATCH_ERROR;
+ }
+
+ if (os->score->expr_type == EXPR_CONSTANT
+ && mpz_sgn (os->score->value.integer) < 0)
+ {
+ gfc_error ("score argument must be non-negative at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match (" )") != MATCH_YES)
+ {
+ gfc_error ("expected ')' at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match (" :") != MATCH_YES)
+ {
+ gfc_error ("expected : at %C");
+ return MATCH_ERROR;
+ }
+ }
+
+ gfc_omp_trait_property *otp = gfc_get_omp_trait_property ();
+ otp->property_kind = property_kind;
+ otp->next = os->properties;
+ os->properties = otp;
+
+ switch (property_kind)
+ {
+ case CTX_PROPERTY_USER:
+ do
+ {
+ if (gfc_match_expr (&otp->expr) != MATCH_YES)
+ {
+ gfc_error ("property must be constant integer "
+ "expression or string literal at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match (" ,") != MATCH_YES)
+ break;
+ }
+ while (1);
+ break;
+ case CTX_PROPERTY_ID:
+ {
+ char buf[GFC_MAX_SYMBOL_LEN + 1];
+ if (gfc_match_name (buf) == MATCH_YES)
+ {
+ otp->name = XNEWVEC (char, strlen (buf) + 1);
+ strcpy (otp->name, buf);
+ }
+ else
+ {
+ gfc_error ("expected identifier at %C");
+ return MATCH_ERROR;
+ }
+ }
+ break;
+ case CTX_PROPERTY_NAME_LIST:
+ do
+ {
+ char buf[GFC_MAX_SYMBOL_LEN + 1];
+ if (gfc_match_name (buf) == MATCH_YES)
+ {
+ otp->name = XNEWVEC (char, strlen (buf) + 1);
+ strcpy (otp->name, buf);
+ otp->is_name = true;
+ }
+ else if (gfc_match_literal_constant (&otp->expr, 0)
+ != MATCH_YES
+ || otp->expr->ts.type != BT_CHARACTER)
+ {
+ gfc_error ("expected identifier or string literal "
+ "at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match (" ,") == MATCH_YES)
+ {
+ otp = gfc_get_omp_trait_property ();
+ otp->property_kind = property_kind;
+ otp->next = os->properties;
+ os->properties = otp;
+ }
+ else
+ break;
+ }
+ while (1);
+ break;
+ case CTX_PROPERTY_EXPR:
+ if (gfc_match_expr (&otp->expr) != MATCH_YES)
+ {
+ gfc_error ("expected expression at %C");
+ return MATCH_ERROR;
+ }
+ if (!gfc_resolve_expr (otp->expr)
+ || (otp->expr->ts.type != BT_LOGICAL
+ && otp->expr->ts.type != BT_INTEGER)
+ || otp->expr->rank != 0)
+ {
+ gfc_error ("property must be constant integer or logical "
+ "expression at %C");
+ return MATCH_ERROR;
+ }
+ break;
+ case CTX_PROPERTY_SIMD:
+ {
+ if (gfc_match_omp_clauses (&otp->clauses,
+ OMP_DECLARE_SIMD_CLAUSES,
+ true, false, false, true)
+ != MATCH_YES)
+ {
+ gfc_error ("expected simd clause at %C");
+ return MATCH_ERROR;
+ }
+ break;
+ }
+ default:
+ gcc_unreachable ();
+ }
+
+ if (gfc_match (" )") != MATCH_YES)
+ {
+ gfc_error ("expected ')' at %C");
+ return MATCH_ERROR;
+ }
+ }
+ else if (property_kind == CTX_PROPERTY_NAME_LIST
+ || property_kind == CTX_PROPERTY_ID
+ || property_kind == CTX_PROPERTY_EXPR)
+ {
+ if (gfc_match (" (") != MATCH_YES)
+ {
+ gfc_error ("expected '(' at %C");
+ return MATCH_ERROR;
+ }
+ }
+
+ if (gfc_match (" ,") != MATCH_YES)
+ break;
+ }
+ while (1);
+
+ return MATCH_YES;
+}
+
+/* OpenMP 5.0:
+
+ trait-set-selector[,trait-set-selector[,...]]
+
+ trait-set-selector:
+ trait-set-selector-name = { trait-selector[, trait-selector[, ...]] }
+
+ trait-set-selector-name:
+ constructor
+ device
+ implementation
+ user */
+
+match
+gfc_match_omp_context_selector_specification (gfc_omp_declare_variant *odv)
+{
+ do
+ {
+ match m;
+ const char *selector_sets[] = { "construct", "device",
+ "implementation", "user" };
+ const int selector_set_count
+ = sizeof (selector_sets) / sizeof (*selector_sets);
+ int i;
+ char buf[GFC_MAX_SYMBOL_LEN + 1];
+
+ m = gfc_match_name (buf);
+ if (m == MATCH_YES)
+ for (i = 0; i < selector_set_count; i++)
+ if (strcmp (buf, selector_sets[i]) == 0)
+ break;
+
+ if (m != MATCH_YES || i == selector_set_count)
+ {
+ gfc_error ("expected 'construct', 'device', 'implementation' or "
+ "'user' at %C");
+ return MATCH_ERROR;
+ }
+
+ m = gfc_match (" =");
+ if (m != MATCH_YES)
+ {
+ gfc_error ("expected '=' at %C");
+ return MATCH_ERROR;
+ }
+
+ m = gfc_match (" {");
+ if (m != MATCH_YES)
+ {
+ gfc_error ("expected '{' at %C");
+ return MATCH_ERROR;
+ }
+
+ gfc_omp_set_selector *oss = gfc_get_omp_set_selector ();
+ oss->next = odv->set_selectors;
+ oss->trait_set_selector_name = selector_sets[i];
+ odv->set_selectors = oss;
+
+ if (gfc_match_omp_context_selector (oss) != MATCH_YES)
+ return MATCH_ERROR;
+
+ m = gfc_match (" }");
+ if (m != MATCH_YES)
+ {
+ gfc_error ("expected '}' at %C");
+ return MATCH_ERROR;
+ }
+
+ m = gfc_match (" ,");
+ if (m != MATCH_YES)
+ break;
+ }
+ while (1);
+
+ return MATCH_YES;
+}
+
+
+match
+gfc_match_omp_declare_variant (void)
+{
+ bool first_p = true;
+ char buf[GFC_MAX_SYMBOL_LEN + 1];
+
+ if (gfc_match (" (") != MATCH_YES)
+ {
+ gfc_error ("expected '(' at %C");
+ return MATCH_ERROR;
+ }
+
+ gfc_symtree *base_proc_st, *variant_proc_st;
+ if (gfc_match_name (buf) != MATCH_YES)
+ {
+ gfc_error ("expected name at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_get_ha_sym_tree (buf, &base_proc_st))
+ return MATCH_ERROR;
+
+ if (gfc_match (" :") == MATCH_YES)
+ {
+ if (gfc_match_name (buf) != MATCH_YES)
+ {
+ gfc_error ("expected variant name at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_get_ha_sym_tree (buf, &variant_proc_st))
+ return MATCH_ERROR;
+ }
+ else
+ {
+ /* Base procedure not specified. */
+ variant_proc_st = base_proc_st;
+ base_proc_st = NULL;
+ }
+
+ gfc_omp_declare_variant *odv;
+ odv = gfc_get_omp_declare_variant ();
+ odv->where = gfc_current_locus;
+ odv->variant_proc_symtree = variant_proc_st;
+ odv->base_proc_symtree = base_proc_st;
+ odv->next = NULL;
+ odv->error_p = false;
+
+ /* Add the new declare variant to the end of the list. */
+ gfc_omp_declare_variant **prev_next = &gfc_current_ns->omp_declare_variant;
+ while (*prev_next)
+ prev_next = &((*prev_next)->next);
+ *prev_next = odv;
+
+ if (gfc_match (" )") != MATCH_YES)
+ {
+ gfc_error ("expected ')' at %C");
+ return MATCH_ERROR;
+ }
+
+ for (;;)
+ {
+ if (gfc_match (" match") != MATCH_YES)
+ {
+ if (first_p)
+ {
+ gfc_error ("expected 'match' at %C");
+ return MATCH_ERROR;
+ }
+ else
+ break;
+ }
+
+ if (gfc_match (" (") != MATCH_YES)
+ {
+ gfc_error ("expected '(' at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match_omp_context_selector_specification (odv) != MATCH_YES)
+ return MATCH_ERROR;
+
+ if (gfc_match (" )") != MATCH_YES)
+ {
+ gfc_error ("expected ')' at %C");
+ return MATCH_ERROR;
+ }
+
+ first_p = false;
+ }
+
+ return MATCH_YES;
+}
+
+
match
gfc_match_omp_threadprivate (void)
{
diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c
index 7d765a0866d..2a454be79b0 100644
--- a/gcc/fortran/parse.c
+++ b/gcc/fortran/parse.c
@@ -26,6 +26,8 @@ along with GCC; see the file COPYING3. If not see
#include <setjmp.h>
#include "match.h"
#include "parse.h"
+#include "tree-core.h"
+#include "omp-general.h"
/* Current statement label. Zero means no statement label. Because new_st
can get wiped during statement matching, we have to keep it separate. */
@@ -860,6 +862,8 @@ decode_omp_directive (void)
ST_OMP_DECLARE_SIMD);
matchdo ("declare target", gfc_match_omp_declare_target,
ST_OMP_DECLARE_TARGET);
+ matchdo ("declare variant", gfc_match_omp_declare_variant,
+ ST_OMP_DECLARE_VARIANT);
break;
case 's':
matchs ("simd", gfc_match_omp_simd, ST_OMP_SIMD);
@@ -1718,6 +1722,7 @@ next_statement (void)
#define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \
case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION: \
+ case ST_OMP_DECLARE_VARIANT: \
case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE
/* Block end statements. Errors associated with interchanging these
@@ -2361,6 +2366,9 @@ gfc_ascii_statement (gfc_statement st)
case ST_OMP_DECLARE_TARGET:
p = "!$OMP DECLARE TARGET";
break;
+ case ST_OMP_DECLARE_VARIANT:
+ p = "!$OMP DECLARE VARIANT";
+ break;
case ST_OMP_DEPOBJ:
p = "!$OMP DEPOBJ";
break;
@@ -6793,6 +6801,24 @@ done:
gfc_current_ns = gfc_current_ns->sibling)
gfc_check_omp_requires (gfc_current_ns, omp_requires);
+ /* Populate omp_requires_mask (needed for resolving OpenMP
+ metadirectives and declare variant). */
+ switch (omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
+ {
+ case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST:
+ omp_requires_mask
+ = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_SEQ_CST);
+ break;
+ case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL:
+ omp_requires_mask
+ = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_ACQ_REL);
+ break;
+ case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED:
+ omp_requires_mask
+ = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_RELAXED);
+ break;
+ }
+
/* Do the parse tree dump. */
gfc_current_ns = flag_dump_fortran_original ? gfc_global_ns_list : NULL;
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 6d61bf4982b..2c4acd5abe1 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -4046,6 +4046,7 @@ gfc_free_namespace (gfc_namespace *ns)
free_tb_tree (ns->tb_uop_root);
gfc_free_finalizer_list (ns->finalizers);
gfc_free_omp_declare_simd_list (ns->omp_declare_simd);
+ gfc_free_omp_declare_variant_list (ns->omp_declare_variant);
gfc_free_charlen (ns->cl_list, NULL);
free_st_labels (ns->st_labels);
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index c758d26febf..3d755099246 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -2361,9 +2361,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;
}
@@ -3111,6 +3115,12 @@ gfc_create_function_decl (gfc_namespace * ns, bool global)
if (ns->omp_declare_simd)
gfc_trans_omp_declare_simd (ns);
+
+ /* Handle 'declare variant' directives. The applicable directives might
+ be declared in a parent namespace, so this needs to be called even if
+ there are no local directives. */
+ if (flag_openmp)
+ gfc_trans_omp_declare_variant (ns);
}
/* Return the decl used to hold the function return value. If
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index d234d1b070f..ecd7917a673 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -7258,3 +7258,208 @@ 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))
+ {
+ DECL_ATTRIBUTES (base_fn_decl)
+ = tree_cons (
+ get_identifier ("omp declare variant base"),
+ build_tree_list (gfc_get_symbol_decl (variant_proc_sym),
+ set_selectors),
+ DECL_ATTRIBUTES (base_fn_decl));
+ }
+ }
+ }
+ }
+}
diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h
index 763f8940404..1a24d9b4cdc 100644
--- a/gcc/fortran/trans-stmt.h
+++ b/gcc/fortran/trans-stmt.h
@@ -71,6 +71,7 @@ tree gfc_trans_deallocate_array (tree);
/* trans-openmp.c */
tree gfc_trans_omp_directive (gfc_code *);
void gfc_trans_omp_declare_simd (gfc_namespace *);
+void gfc_trans_omp_declare_variant (gfc_namespace *);
tree gfc_trans_oacc_directive (gfc_code *);
tree gfc_trans_oacc_declare (gfc_namespace *);
diff --git a/gcc/omp-general.c b/gcc/omp-general.c
index 3e5ca94c2a7..44527552413 100644
--- a/gcc/omp-general.c
+++ b/gcc/omp-general.c
@@ -1095,6 +1095,146 @@ omp_maybe_offloaded (void)
return false;
}
+
+/* Diagnose errors in an OpenMP context selector, return CTX if
+ it is correct or error_mark_node otherwise. */
+
+tree
+omp_check_context_selector (location_t loc, tree ctx)
+{
+ /* Each trait-set-selector-name can only be specified once.
+ There are just 4 set names. */
+ for (tree t1 = ctx; t1; t1 = TREE_CHAIN (t1))
+ for (tree t2 = TREE_CHAIN (t1); t2; t2 = TREE_CHAIN (t2))
+ if (TREE_PURPOSE (t1) == TREE_PURPOSE (t2))
+ {
+ error_at (loc, "selector set %qs specified more than once",
+ IDENTIFIER_POINTER (TREE_PURPOSE (t1)));
+ return error_mark_node;
+ }
+ for (tree t = ctx; t; t = TREE_CHAIN (t))
+ {
+ /* Each trait-selector-name can only be specified once. */
+ if (list_length (TREE_VALUE (t)) < 5)
+ {
+ for (tree t1 = TREE_VALUE (t); t1; t1 = TREE_CHAIN (t1))
+ for (tree t2 = TREE_CHAIN (t1); t2; t2 = TREE_CHAIN (t2))
+ if (TREE_PURPOSE (t1) == TREE_PURPOSE (t2))
+ {
+ error_at (loc,
+ "selector %qs specified more than once in set %qs",
+ IDENTIFIER_POINTER (TREE_PURPOSE (t1)),
+ IDENTIFIER_POINTER (TREE_PURPOSE (t)));
+ return error_mark_node;
+ }
+ }
+ else
+ {
+ hash_set<tree> pset;
+ for (tree t1 = TREE_VALUE (t); t1; t1 = TREE_CHAIN (t1))
+ if (pset.add (TREE_PURPOSE (t1)))
+ {
+ error_at (loc,
+ "selector %qs specified more than once in set %qs",
+ IDENTIFIER_POINTER (TREE_PURPOSE (t1)),
+ IDENTIFIER_POINTER (TREE_PURPOSE (t)));
+ return error_mark_node;
+ }
+ }
+
+ static const char *const kind[] = {
+ "host", "nohost", "cpu", "gpu", "fpga", "any", NULL };
+ static const char *const vendor[] = {
+ "amd", "arm", "bsc", "cray", "fujitsu", "gnu", "ibm", "intel",
+ "llvm", "nvidia", "pgi", "ti", "unknown", NULL };
+ static const char *const extension[] = { NULL };
+ static const char *const atomic_default_mem_order[] = {
+ "seq_cst", "relaxed", "acq_rel", NULL };
+ struct known_properties { const char *set; const char *selector;
+ const char *const *props; };
+ known_properties props[] = {
+ { "device", "kind", kind },
+ { "implementation", "vendor", vendor },
+ { "implementation", "extension", extension },
+ { "implementation", "atomic_default_mem_order",
+ atomic_default_mem_order } };
+ for (tree t1 = TREE_VALUE (t); t1; t1 = TREE_CHAIN (t1))
+ for (unsigned i = 0; i < ARRAY_SIZE (props); i++)
+ if (!strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t1)),
+ props[i].selector)
+ && !strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)),
+ props[i].set))
+ for (tree t2 = TREE_VALUE (t1); t2; t2 = TREE_CHAIN (t2))
+ for (unsigned j = 0; ; j++)
+ {
+ if (props[i].props[j] == NULL)
+ {
+ if (TREE_PURPOSE (t2)
+ && !strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t2)),
+ " score"))
+ break;
+ if (props[i].props == atomic_default_mem_order)
+ {
+ error_at (loc,
+ "incorrect property %qs of %qs selector",
+ IDENTIFIER_POINTER (TREE_PURPOSE (t2)),
+ "atomic_default_mem_order");
+ return error_mark_node;
+ }
+ else if (TREE_PURPOSE (t2))
+ warning_at (loc, 0,
+ "unknown property %qs of %qs selector",
+ IDENTIFIER_POINTER (TREE_PURPOSE (t2)),
+ props[i].selector);
+ else
+ warning_at (loc, 0,
+ "unknown property %qE of %qs selector",
+ TREE_VALUE (t2), props[i].selector);
+ break;
+ }
+ else if (TREE_PURPOSE (t2) == NULL_TREE)
+ {
+ const char *str = TREE_STRING_POINTER (TREE_VALUE (t2));
+ if (!strcmp (str, props[i].props[j])
+ && ((size_t) TREE_STRING_LENGTH (TREE_VALUE (t2))
+ == strlen (str) + (lang_GNU_Fortran () ? 0 : 1)))
+ break;
+ }
+ else if (!strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t2)),
+ props[i].props[j]))
+ break;
+ }
+ }
+ return ctx;
+}
+
+
+/* Register VARIANT as variant of some base function marked with
+ #pragma omp declare variant. CONSTRUCT is corresponding construct
+ selector set. */
+
+void
+omp_mark_declare_variant (location_t loc, tree variant, tree construct)
+{
+ tree attr = lookup_attribute ("omp declare variant variant",
+ DECL_ATTRIBUTES (variant));
+ if (attr == NULL_TREE)
+ {
+ attr = tree_cons (get_identifier ("omp declare variant variant"),
+ unshare_expr (construct),
+ DECL_ATTRIBUTES (variant));
+ DECL_ATTRIBUTES (variant) = attr;
+ return;
+ }
+ if ((TREE_VALUE (attr) != NULL_TREE) != (construct != NULL_TREE)
+ || (construct != NULL_TREE
+ && omp_context_selector_set_compare ("construct", TREE_VALUE (attr),
+ construct)))
+ error_at (loc, "%qD used as a variant with incompatible %<construct%> "
+ "selector sets", variant);
+}
+
+
/* Return a name from PROP, a property in selectors accepting
name lists. */
@@ -1106,7 +1246,8 @@ omp_context_name_list_prop (tree prop)
else
{
const char *ret = TREE_STRING_POINTER (TREE_VALUE (prop));
- if ((size_t) TREE_STRING_LENGTH (TREE_VALUE (prop)) == strlen (ret) + 1)
+ if ((size_t) TREE_STRING_LENGTH (TREE_VALUE (prop))
+ == strlen (ret) + (lang_GNU_Fortran () ? 0 : 1))
return ret;
return NULL;
}
diff --git a/gcc/omp-general.h b/gcc/omp-general.h
index 6a1468d2798..8fe744c6a7a 100644
--- a/gcc/omp-general.h
+++ b/gcc/omp-general.h
@@ -104,6 +104,9 @@ extern tree find_combined_omp_for (tree *, int *, void *);
extern poly_uint64 omp_max_vf (void);
extern int omp_max_simt_vf (void);
extern int omp_constructor_traits_to_codes (tree, enum tree_code *);
+extern tree omp_check_context_selector (location_t loc, tree ctx);
+extern void omp_mark_declare_variant (location_t loc, tree variant,
+ tree construct);
extern int omp_context_selector_matches (tree);
extern int omp_context_selector_set_compare (const char *, tree, tree);
extern tree omp_get_context_selector (tree, const char *, const char *);
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-1.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-1.f90
new file mode 100644
index 00000000000..de09dbfe806
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-1.f90
@@ -0,0 +1,93 @@
+module main
+ implicit none
+
+ interface
+ integer function foo (a, b, c)
+ integer, intent(in) :: a, b
+ integer, intent(inout) :: c
+ end function
+
+ integer function bar (a, b, c)
+ integer, intent(in) :: a, b
+ integer, intent(inout) :: c
+ end function
+
+ integer function baz (a, b, c)
+ integer, intent(in) :: a, b
+ integer, intent(inout) :: c
+
+ !$omp declare variant (foo) &
+ !$omp & match (construct={parallel,do}, &
+ !$omp & device={isa(avx512f,avx512vl),kind(host,cpu)}, &
+ !$omp & implementation={vendor(score(0):gnu),unified_shared_memory}, &
+ !$omp & user={condition(score(0):0)})
+ !$omp declare variant (bar) &
+ !$omp & match (device={arch(x86_64,powerpc64),isa(avx512f,popcntb)}, &
+ !$omp & implementation={atomic_default_mem_order(seq_cst),made_up_selector("foo", 13, "bar")}, &
+ !$omp & user={condition(3-3)})
+ end function
+
+ subroutine quux
+ end subroutine quux
+
+ integer function baz3 (x, y, z)
+ integer, intent(in) :: x, y
+ integer, intent(inout) :: z
+
+ !$omp declare variant (bar) match &
+ !$omp & (implementation={atomic_default_mem_order(score(3): acq_rel)})
+ end function
+ end interface
+contains
+ integer function qux ()
+ integer :: i = 3
+
+ qux = baz (1, 2, i)
+ end function
+
+ subroutine corge
+ integer :: i
+ !$omp declare variant (quux) match (construct={parallel,do})
+
+ interface
+ subroutine waldo (x)
+ integer, intent(in) :: x
+ end subroutine
+ end interface
+
+ call waldo (5)
+ !$omp parallel do
+ do i = 1, 3
+ call waldo (6)
+ end do
+ !$omp end parallel do
+
+ !$omp parallel
+ !$omp taskgroup
+ !$omp do
+ do i = 1, 3
+ call waldo (7)
+ end do
+ !$omp end do
+ !$omp end taskgroup
+ !$omp end parallel
+
+ !$omp parallel
+ !$omp master
+ call waldo (8)
+ !$omp end master
+ !$omp end parallel
+ end subroutine
+
+ integer function baz2 (x, y, z)
+ integer, intent(in) :: x, y
+ integer, intent(inout) :: z
+
+ !$omp declare variant (bar) match &
+ !$omp & (implementation={atomic_default_mem_order(relaxed), &
+ !$omp & unified_address, unified_shared_memory, &
+ !$omp & dynamic_allocators, reverse_offload})
+
+ baz2 = x + y + z
+ end function
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-10.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-10.f90
new file mode 100644
index 00000000000..d6d2c8c262b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-10.f90
@@ -0,0 +1,97 @@
+! { dg-do compile }
+! { dg-additional-options "-cpp -foffload=disable -fdump-tree-gimple" }
+! { dg-additional-options "-mavx512bw" { target { i?86-*-* x86_64-*-* } } }
+
+#undef i386
+
+program main
+ !$omp declare target to (test3)
+contains
+ subroutine f01 ()
+ end subroutine
+ subroutine f02 ()
+ !$omp declare variant (f01) match (device={isa(avx512f,avx512bw)})
+ end subroutine
+ subroutine f03 ()
+ end subroutine
+ subroutine f04 ()
+ !$omp declare variant (f03) match (device={kind("any"),arch(x86_64),isa(avx512f,avx512bw)})
+ end subroutine
+ subroutine f05 ()
+ end subroutine
+ subroutine f06 ()
+ !$omp declare variant (f05) match (device={kind(gpu)})
+ end subroutine
+ subroutine f07 ()
+ end subroutine
+ subroutine f08 ()
+ !$omp declare variant (f07) match (device={kind(cpu)})
+ end subroutine
+ subroutine f09 ()
+ end subroutine
+ subroutine f10 ()
+ !$omp declare variant (f09) match (device={isa(sm_35)})
+ end subroutine
+ subroutine f11 ()
+ end subroutine
+ subroutine f12 ()
+ !$omp declare variant (f11) match (device={arch("nvptx")})
+ end subroutine
+ subroutine f13 ()
+ end subroutine
+ subroutine f14 ()
+ !$omp declare variant (f13) match (device={arch(i386),isa("sse4")})
+ end subroutine
+ subroutine f15 ()
+ end subroutine
+ subroutine f16 ()
+ !$omp declare variant (f15) match (device={isa(sse4,ssse3),arch(i386)})
+ end subroutine
+ subroutine f17 ()
+ end subroutine
+ subroutine f18 ()
+ !$omp declare variant (f17) match (device={kind(any,fpga)})
+ end subroutine
+
+ subroutine test1 ()
+ !$omp declare target
+ integer :: i
+
+ call f02 () ! { dg-final { scan-tree-dump-times "f01 \\\(\\\);" 1 "gimple" { target i?86-*-* x86_64-*-* } } }
+ ! { dg-final { scan-tree-dump-times "f02 \\\(\\\);" 1 "gimple" { target { ! { i?86-*-* x86_64-*-* } } } } }
+ call f14 () ! { dg-final { scan-tree-dump-times "f13 \\\(\\\);" 1 "gimple" { target ia32 } } }
+ ! { dg-final { scan-tree-dump-times "f14 \\\(\\\);" 1 "gimple" { target { ! ia32 } } } }
+ call f18 () ! { dg-final { scan-tree-dump-times "f18 \\\(\\\);" 1 "gimple" } } */
+ end subroutine
+
+#if defined(__i386__) || defined(__x86_64__)
+ __attribute__((target ("avx512f,avx512bw")))
+#endif
+ subroutine test2 ()
+ !$omp target
+ call f04 () ! { dg-final { scan-tree-dump-times "f03 \\\(\\\);" 1 "gimple" { target { { i?86-*-* x86_64-*-* } && lp64 } } } }
+ ! { dg-final { scan-tree-dump-times "f04 \\\(\\\);" 1 "gimple" { target { { ! lp64 } || { ! { i?86-*-* x86_64-*-* } } } } } }
+ !$omp end target
+ !$omp target
+ call f16 () ! { dg-final { scan-tree-dump-times "f15 \\\(\\\);" 1 "gimple" { target ia32 } } }
+ ! { dg-final { scan-tree-dump-times "f16 \\\(\\\);" 1 "gimple" { target { ! ia32 } } } }
+ !$omp end target
+ end subroutine
+
+ subroutine test3 ()
+ call f06 () ! { dg-final { scan-tree-dump-times "f06 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* amdgcn*-*-* } } } } }
+ call f08 () ! { dg-final { scan-tree-dump-times "f07 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* amdgcn*-*-* } } } } }
+ end subroutine
+
+ subroutine test4 ()
+ !$omp target
+ call f10 () ! { dg-final { scan-tree-dump-times "f10 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* amdgcn*-*-* } } } } }
+ !$omp end target
+
+ !$omp target
+ call f12 () ! { dg-final { scan-tree-dump-times "f12 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* } } } } }
+ ! { dg-final { scan-tree-dump-times "f11 \\\(\\\);" 1 "gimple" { target { nvptx*-*-* } } } }
+ !$omp end target
+ end subroutine
+end program
+
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-11.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-11.f90
new file mode 100644
index 00000000000..60aa0fcb3b0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-11.f90
@@ -0,0 +1,134 @@
+! { dg-do compile }
+! { dg-additional-options "-foffload=disable -fdump-tree-gimple" }
+! { dg-additional-options "-mavx512bw -mavx512vl" { target { i?86-*-* x86_64-*-* } } }
+
+program main
+ implicit none
+contains
+ subroutine f01 ()
+ end subroutine
+
+ subroutine f02 ()
+ end subroutine
+
+ subroutine f03 ()
+ !$omp declare variant (f01) match (device={isa(avx512f,"avx512vl")})
+ !$omp declare variant (f02) match (device={isa(avx512bw,avx512vl,"avx512f")})
+ end subroutine
+
+ subroutine f04 ()
+ end subroutine
+
+ subroutine f05 ()
+ end subroutine
+
+ subroutine f06 ()
+ !$omp declare variant (f04) match (device={isa(avx512f,avx512vl)})
+ !$omp declare variant (f05) match (device={isa(avx512bw,avx512vl,avx512f)})
+ end subroutine
+
+ subroutine f07 ()
+ end subroutine
+
+ subroutine f08 ()
+ end subroutine
+
+ subroutine f09 ()
+ !$omp declare variant (f07) match (device={isa(sse4,"sse4.1","sse4.2",sse3,"avx")})
+ !$omp declare variant (f08) match (device={isa("avx",sse3)})
+ end subroutine
+
+ subroutine f10 ()
+ end subroutine
+
+ subroutine f11 ()
+ end subroutine
+
+ subroutine f12 ()
+ end subroutine
+
+ subroutine f13 ()
+ !$omp declare variant (f10) match (device={isa("avx512f")})
+ !$omp declare variant (f11) match (user={condition(1)},device={isa(avx512f)},implementation={vendor(gnu)})
+ !$omp declare variant (f12) match (user={condition(2 + 1)},device={isa(avx512f)})
+ end subroutine
+
+ subroutine f14 ()
+ end subroutine
+
+ subroutine f15 ()
+ end subroutine
+
+ subroutine f16 ()
+ end subroutine
+
+ subroutine f17 ()
+ end subroutine
+
+ subroutine f18 ()
+ !$omp declare variant (f14) match (construct={teams,do})
+ !$omp declare variant (f15) match (construct={teams,parallel,do})
+ !$omp declare variant (f16) match (construct={do})
+ !$omp declare variant (f17) match (construct={parallel,do})
+ end subroutine
+
+ subroutine f19 ()
+ end subroutine
+
+ subroutine f20 ()
+ end subroutine
+
+ subroutine f21 ()
+ end subroutine
+
+ subroutine f22 ()
+ end subroutine
+
+ subroutine f23 ()
+ !$omp declare variant (f19) match (construct={teams,do})
+ !$omp declare variant (f20) match (construct={teams,parallel,do})
+ !$omp declare variant (f21) match (construct={do})
+ !$omp declare variant (f22) match (construct={parallel,do})
+ end subroutine
+
+ subroutine f24 ()
+ end subroutine
+
+ subroutine f25 ()
+ end subroutine
+
+ subroutine f26 ()
+ end subroutine
+
+ subroutine f27 ()
+ !$omp declare variant (f24) match (device={kind(cpu)})
+ !$omp declare variant (f25) match (device={kind(cpu),isa(avx512f),arch(x86_64)})
+ !$omp declare variant (f26) match (device={arch(x86_64),kind(cpu)})
+ end subroutine
+
+ subroutine test1
+ integer :: i
+ call f03 () ! { dg-final { scan-tree-dump-times "f02 \\\(\\\);" 1 "gimple" { target i?86-*-* x86_64-*-* } } }
+ ! { dg-final { scan-tree-dump-times "f03 \\\(\\\);" 1 "gimple" { target { ! { i?86-*-* x86_64-*-* } } } } }
+ call f09 () ! { dg-final { scan-tree-dump-times "f07 \\\(\\\);" 1 "gimple" { target i?86-*-* x86_64-*-* } } }
+ ! { dg-final { scan-tree-dump-times "f09 \\\(\\\);" 1 "gimple" { target { ! { i?86-*-* x86_64-*-* } } } } }
+ call f13 () ! { dg-final { scan-tree-dump-times "f11 \\\(\\\);" 1 "gimple" { target i?86-*-* x86_64-*-* } } }
+ ! { dg-final { scan-tree-dump-times "f13 \\\(\\\);" 1 "gimple" { target { ! { i?86-*-* x86_64-*-* } } } } }
+ !$omp teams distribute parallel do
+ do i = 1, 2
+ call f18 () ! { dg-final { scan-tree-dump-times "f15 \\\(\\\);" 1 "gimple" } }
+ end do
+ !$omp end teams distribute parallel do
+
+ !$omp parallel do
+ do i = 1, 2
+ call f23 () ! { dg-final { scan-tree-dump-times "f22 \\\(\\\);" 1 "gimple" } }
+ end do
+ !$omp end parallel do
+
+ call f27 () ! { dg-final { scan-tree-dump-times "f25 \\\(\\\);" 1 "gimple" { target { { i?86-*-* x86_64-*-* } && lp64 } } } }
+ ! { dg-final { scan-tree-dump-times "f24 \\\(\\\);" 1 "gimple" { target { { i?86-*-* x86_64-*-* } && { ! lp64 } } } } }
+ ! { dg-final { scan-tree-dump-times "f24 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* amdgcn*-*-* i?86-*-* x86_64-*-* } } } } }
+ ! { dg-final { scan-tree-dump-times "f27 \\\(\\\);" 1 "gimple" { target { nvptx*-*-* amdgcn*-*-* } } } }
+ end subroutine
+end program
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-12.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-12.f90
new file mode 100644
index 00000000000..610693e9807
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-12.f90
@@ -0,0 +1,159 @@
+! { dg-do compile }
+! { dg-additional-options "-foffload=disable -fdump-tree-gimple" }
+! { dg-additional-options "-mavx512bw -mavx512vl" { target { i?86-*-* x86_64-*-* } } }
+
+program main
+ !$omp requires atomic_default_mem_order(seq_cst)
+contains
+ subroutine f01 ()
+ end subroutine
+
+ subroutine f02 ()
+ end subroutine
+
+ subroutine f03 ()
+ end subroutine
+
+ subroutine f04 ()
+ !$omp declare variant (f01) match (device={isa("avx512f","avx512vl")}) ! 16
+ !$omp declare variant (f02) match (implementation={vendor(score(15):gnu)})
+ !$omp declare variant (f03) match (user={condition(score(11):1)})
+ end subroutine
+
+ subroutine f05 ()
+ end subroutine
+
+ subroutine f06 ()
+ end subroutine
+
+ subroutine f07 ()
+ end subroutine
+
+ subroutine f08 ()
+ !$omp declare variant (f05) match (device={isa(avx512f,avx512vl)}) ! 16
+ !$omp declare variant (f06) match (implementation={vendor(score(15):gnu)})
+ !$omp declare variant (f07) match (user={condition(score(17):1)})
+ end subroutine
+
+ subroutine f09 ()
+ end subroutine
+
+ subroutine f10 ()
+ end subroutine
+
+ subroutine f11 ()
+ end subroutine
+
+ subroutine f12 ()
+ end subroutine
+
+ subroutine f13 ()
+ !$omp declare variant (f09) match (device={arch(x86_64)},user={condition(score(65):1)}) ! 64+65
+ !$omp declare variant (f10) match (implementation={vendor(score(127):"gnu")})
+ !$omp declare variant (f11) match (device={isa(ssse3)}) ! 128
+ !$omp declare variant (f12) match (implementation={atomic_default_mem_order(score(126):seq_cst)})
+ end subroutine
+
+ subroutine f14 ()
+ end subroutine
+
+ subroutine f15 ()
+ end subroutine
+
+ subroutine f16 ()
+ end subroutine
+
+ subroutine f17 ()
+ !$omp declare variant (f14) match (construct={teams,parallel,do}) ! 16+8+4
+ !$omp declare variant (f15) match (construct={parallel},user={condition(score(19):1)}) ! 8+19
+ !$omp declare variant (f16) match (implementation={atomic_default_mem_order(score(27):seq_cst)})
+ end subroutine
+
+ subroutine f18 ()
+ end subroutine
+
+ subroutine f19 ()
+ end subroutine
+
+ subroutine f20 ()
+ end subroutine
+
+ subroutine f21 ()
+ !$omp declare variant (f18) match (construct={teams,parallel,do}) ! 16+8+4
+ !$omp declare variant (f19) match (construct={do},user={condition(score(25):1)}) ! 4+25
+ !$omp declare variant (f20) match (implementation={atomic_default_mem_order(score(28):seq_cst)})
+ end subroutine
+
+ subroutine f22 ()
+ end subroutine
+
+ subroutine f23 ()
+ end subroutine
+
+ subroutine f24 ()
+ end subroutine
+
+ subroutine f25 ()
+ !$omp declare variant (f22) match (construct={parallel,do}) ! 2+1
+ !$omp declare variant (f23) match (construct={do}) ! 0
+ !$omp declare variant (f24) match (implementation={atomic_default_mem_order(score(2):seq_cst)})
+ end subroutine
+
+ subroutine f26 ()
+ end subroutine
+
+ subroutine f27 ()
+ end subroutine
+
+ subroutine f28 ()
+ end subroutine
+
+ subroutine f29 ()
+ !$omp declare variant (f26) match (construct={parallel,do}) ! 2+1
+ !$omp declare variant (f27) match (construct={do},user={condition(1)}) ! 4
+ !$omp declare variant (f28) match (implementation={atomic_default_mem_order(score(3):seq_cst)})
+ end subroutine
+
+ subroutine test1 ()
+ integer :: i, j
+
+ !$omp parallel do ! 2 constructs in OpenMP context, isa has score 2^4.
+ do i = 1, 2
+ call f04 () ! { dg-final { scan-tree-dump-times "f01 \\\(\\\);" 1 "gimple" { target i?86-*-* x86_64-*-* } } }
+ ! { dg-final { scan-tree-dump-times "f02 \\\(\\\);" 1 "gimple" { target { ! { i?86-*-* x86_64-*-* } } } } }
+ end do
+ !$omp end parallel do
+
+ !$omp target teams ! 2 constructs in OpenMP context, isa has score 2^4.
+ call f08 () ! { dg-final { scan-tree-dump-times "f07 \\\(\\\);" 1 "gimple" } }
+ !$omp end target teams
+
+ !$omp teams
+ !$omp parallel do
+ do i = 1, 2
+ !$omp parallel do ! 5 constructs in OpenMP context, arch is 2^6, isa 2^7.
+ do j = 1, 2
+ call f13 () ! { dg-final { scan-tree-dump-times "f09 \\\(\\\);" 1 "gimple" { target { { i?86-*-* x86_64-*-* } && lp64 } } } }
+ ! { dg-final { scan-tree-dump-times "f11 \\\(\\\);" 1 "gimple" { target { { i?86-*-* x86_64-*-* } && { ! lp64 } } } } }
+ ! { dg-final { scan-tree-dump-times "f10 \\\(\\\);" 1 "gimple" { target { ! { i?86-*-* x86_64-*-* } } } } }
+ call f17 () ! { dg-final { scan-tree-dump-times "f14 \\\(\\\);" 1 "gimple" } }
+ call f21 () ! { dg-final { scan-tree-dump-times "f19 \\\(\\\);" 1 "gimple" } }
+ end do
+ !$omp end parallel do
+ end do
+ !$omp end parallel do
+ !$omp end teams
+
+ !$omp do
+ do i = 1, 2
+ !$omp parallel do
+ do j = 1, 2
+ call f25 (); ! { dg-final { scan-tree-dump-times "f22 \\\(\\\);" 1 "gimple" } }
+ call f29 (); ! { dg-final { scan-tree-dump-times "f27 \\\(\\\);" 1 "gimple" } }
+ end do
+ !$omp end parallel do
+ end do
+ !$omp end do
+ end subroutine
+end program
+
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-13.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-13.f90
new file mode 100644
index 00000000000..91648f9bcf4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-13.f90
@@ -0,0 +1,48 @@
+! { dg-do compile { target vect_simd_clones } }
+! { dg-additional-options "-fdump-tree-gimple" }
+! { dg-additional-options "-mno-sse3" { target { i?86-*-* x86_64-*-* } } }
+
+program main
+ implicit none
+contains
+ integer function f01 (x)
+ integer, intent(in) :: x
+ f01 = x
+ end function
+
+ integer function f02 (x)
+ integer, intent(in) :: x
+ f02 = x
+ end function
+
+ integer function f03 (x)
+ integer, intent(in) :: x
+ f03 = x
+ end function
+
+ integer function f04 (x)
+ integer, intent(in) :: x
+ f04 = x
+ end function
+
+ integer function f05 (x)
+ integer, intent(in) :: x
+
+ !$omp declare variant (f01) match (device={isa("avx512f")}) ! 4 or 8
+ !$omp declare variant (f02) match (implementation={vendor(score(3):gnu)},device={kind(cpu)}) ! (1 or 2) + 3
+ !$omp declare variant (f03) match (user={condition(score(9):1)})
+ !$omp declare variant (f04) match (implementation={vendor(score(6):gnu)},device={kind(host)}) ! (1 or 2) + 6
+ f05 = x
+ end function
+
+ integer function test1 (x)
+ !$omp declare simd
+ integer, intent(in) :: x
+
+ ! 0 or 1 (the latter if in a declare simd clone) constructs in OpenMP context,
+ ! isa has score 2^2 or 2^3. We can't decide on whether avx512f will match or
+ ! not, that also depends on whether it is a declare simd clone or not and which
+ ! one, but the f03 variant has a higher score anyway. */
+ test1 = f05 (x) ! { dg-final { scan-tree-dump-times "f03 \\\(x" 1 "gimple" } }
+ end function
+end program
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-14.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-14.f90
new file mode 100644
index 00000000000..06c9a5d1ed8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-14.f90
@@ -0,0 +1,49 @@
+! { dg-do compile { target vect_simd_clones } }
+! { dg-additional-options "-O0 -fdump-tree-gimple -fdump-tree-optimized" }
+! { dg-additional-options "-mno-sse3" { target { i?86-*-* x86_64-*-* } } }
+
+module main
+ implicit none
+contains
+ integer function f01 (x)
+ integer, intent (in) :: x
+ f01 = x
+ end function
+
+ integer function f02 (x)
+ integer, intent (in) :: x
+ f02 = x
+ end function
+
+ integer function f03 (x)
+ integer, intent (in) :: x
+ f03 = x
+ end function
+
+ integer function f04 (x)
+ integer, intent(in) :: x
+
+ !$omp declare variant (f01) match (device={isa("avx512f")}) ! 4 or 8
+ !$omp declare variant (f02) match (implementation={vendor(score(3):gnu)},device={kind(cpu)}) ! (1 or 2) + 3
+ !$omp declare variant (f03) match (implementation={vendor(score(5):gnu)},device={kind(host)}) ! (1 or 2) + 5
+ f04 = x
+ end function
+
+ integer function test1 (x)
+ !$omp declare simd
+ integer, intent (in) :: x
+ integer :: a, b
+
+ ! At gimplification time, we can't decide yet which function to call.
+ ! { dg-final { scan-tree-dump-times "f04 \\\(x" 2 "gimple" } }
+ ! After simd clones are created, the original non-clone test1 shall
+ ! call f03 (score 6), the sse2/avx/avx2 clones too, but avx512f clones
+ ! shall call f01 with score 8.
+ ! { dg-final { scan-tree-dump-not "f04 \\\(x" "optimized" } }
+ ! { dg-final { scan-tree-dump-times "f03 \\\(x" 14 "optimized" } }
+ ! { dg-final { scan-tree-dump-times "f01 \\\(x" 4 "optimized" } }
+ a = f04 (x)
+ b = f04 (x)
+ test1 = a + b
+ end function
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-15.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-15.f90
new file mode 100644
index 00000000000..b2ad96a8998
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-15.f90
@@ -0,0 +1,24 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-gimple" }
+
+! Test 'declare variant' directive with an explicit base procedure name.
+
+module main
+ implicit none
+
+ !$omp declare variant (base: variant) match (construct={target,parallel})
+contains
+ subroutine variant ()
+ end subroutine
+
+ subroutine base ()
+ end subroutine
+
+ subroutine test1 ()
+ !$omp target
+ !$omp parallel
+ call base () ! { dg-final { scan-tree-dump-times "variant \\\(\\\);" 1 "gimple" } }
+ !$omp end parallel
+ !$omp end target
+ end subroutine
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-16.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-16.f90
new file mode 100644
index 00000000000..fc97322e667
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-16.f90
@@ -0,0 +1,24 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-gimple" }
+
+! Test that 'declare variant' works when applied to an external subroutine
+
+module main
+ implicit none
+
+ interface
+ subroutine base ()
+ !$omp declare variant (variant) match (construct={parallel})
+ end subroutine
+ end interface
+
+contains
+ subroutine variant ()
+ end subroutine
+
+ subroutine test ()
+ !$omp parallel
+ call base () ! { dg-final { scan-tree-dump-times "variant \\\(\\\);" 1 "gimple" } }
+ !$omp end parallel
+ end subroutine
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-17.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-17.f90
new file mode 100644
index 00000000000..df57f9c089c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-17.f90
@@ -0,0 +1,17 @@
+! { dg-do compile }
+
+! Declare variant directives should only appear in the specification parts.
+
+program main
+ implicit none
+
+ continue
+
+ !$omp declare variant (base: variant) match (construct={parallel}) ! { dg-error "Unexpected \\\!\\\$OMP DECLARE VARIANT statement at .1." }
+contains
+ subroutine base ()
+ continue
+
+ !$omp declare variant (variant) match (construct={parallel}) ! { dg-error "Unexpected \\\!\\\$OMP DECLARE VARIANT statement at .1." }
+ end subroutine
+end program
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-18.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-18.f90
new file mode 100644
index 00000000000..f97cf34a28a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-18.f90
@@ -0,0 +1,17 @@
+! { dg-do compile }
+
+! The base procedure must have an accessible explicit interface when the
+! directive appears.
+
+program main
+ interface
+ subroutine base_proc ()
+ end subroutine
+ end interface
+
+ !$omp declare variant (base_proc: variant_proc) match (construct={parallel})
+ !$omp declare variant (base_proc2: variant_proc) match (construct={parallel}) ! { dg-error "The base procedure at .1. must have an explicit interface" }
+contains
+ subroutine variant_proc ()
+ end subroutine
+end program
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-19.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-19.f90
new file mode 100644
index 00000000000..d387f5e9065
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-19.f90
@@ -0,0 +1,49 @@
+! { dg-do compile }
+
+! Test Fortran-specific compilation failures.
+
+module main
+ implicit none
+
+ interface base_gen
+ subroutine base_gen_int (x)
+ integer :: x
+ end subroutine
+
+ subroutine base_gen_real (x)
+ real :: x
+ end subroutine
+ end interface
+
+ interface
+ subroutine base_p ()
+ end subroutine
+ end interface
+
+ procedure (base_p), pointer :: base_proc_ptr
+
+ !$omp declare variant (base_entry: variant) match (construct={parallel}) ! { dg-error "The base name at .1. must not be an entry name" }
+ !$omp declare variant (base_proc_ptr: variant) match (construct={parallel}) ! { dg-error "The base name at .1. must not be a procedure pointer" }
+ !$omp declare variant (base_gen: variant2) match (construct={parallel}) ! { dg-error "The base name at .1. must not be a generic name" }
+ !$omp declare variant (variant) match (construct={parallel}) ! { dg-error "The base name for 'declare variant' must be specified at .1." }
+
+contains
+ subroutine base ()
+ entry base_entry
+ end subroutine
+
+ subroutine base2 ()
+ !$omp declare variant (variant2) match (construct={parallel}) ! { dg-error "variant .variant2. and base .base2. at .1. have incompatible types: .variant2. has the wrong number of arguments" }
+ end subroutine
+
+ subroutine base3 ()
+ !$omp declare variant (base: variant2) match (construct={parallel}) ! { dg-error "The base name at .1. does not match the name of the current procedure" }
+ end subroutine
+
+ subroutine variant ()
+ end subroutine
+
+ subroutine variant2 (x)
+ integer :: x
+ end subroutine
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90
new file mode 100644
index 00000000000..63d77780196
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-2.f90
@@ -0,0 +1,197 @@
+module main
+ implicit none
+contains
+ subroutine f0 ()
+ end subroutine
+ subroutine f1 ()
+ end subroutine
+ subroutine f2 ()
+ !$omp declare variant ! { dg-error "expected '\\(' at .1." }
+ end subroutine
+ subroutine f3 ()
+ !$omp declare variant ( ! { dg-error "" }
+ end subroutine
+ subroutine f4 ()
+ !$omp declare variant () ! { dg-error "" }
+ end subroutine
+ subroutine f5 ()
+ !$omp declare variant match(user={condition(0)}) ! { dg-error "expected '\\(' at .1." }
+ end subroutine
+ subroutine f6 ()
+ !$omp declare variant (f1) ! { dg-error "expected 'match' at .1." }
+ end subroutine
+ subroutine f7 ()
+ !$omp declare variant (f1) simd ! { dg-error "expected 'match' at .1." }
+ end subroutine
+ subroutine f8 ()
+ !$omp declare variant (f1) match ! { dg-error "expected '\\(' at .1." }
+ end subroutine
+ subroutine f9 ()
+ !$omp declare variant (f1) match( ! { dg-error "expected 'construct', 'device', 'implementation' or 'user' at .1." }
+ end subroutine
+ subroutine f10 ()
+ !$omp declare variant (f1) match() ! { dg-error "expected 'construct', 'device', 'implementation' or 'user' at .1." }
+ end subroutine
+ subroutine f11 ()
+ !$omp declare variant (f1) match(foo) ! { dg-error "expected 'construct', 'device', 'implementation' or 'user' at .1." }
+ end subroutine
+ subroutine f12 ()
+ !$omp declare variant (f1) match(something={something}) ! { dg-error "expected 'construct', 'device', 'implementation' or 'user' at .1." }
+ end subroutine
+ subroutine f13 ()
+ !$omp declare variant (f1) match(user) ! { dg-error "expected '=' at .1." }
+ end subroutine
+ subroutine f14 ()
+ !$omp declare variant (f1) match(user=) ! { dg-error "expected '\\\{' at .1." }
+ end subroutine
+ subroutine f15 ()
+ !$omp declare variant (f1) match(user= ! { dg-error "expected '\\\{' at .1." }
+ end subroutine
+ subroutine f16 ()
+ !$omp declare variant (f1) match(user={) ! { dg-error "expected trait selector name at .1." }
+ end subroutine
+ subroutine f17 ()
+ !$omp declare variant (f1) match(user={}) ! { dg-error "expected trait selector name at .1." }
+ end subroutine
+ subroutine f18 ()
+ !$omp declare variant (f1) match(user={condition}) ! { dg-error "expected '\\(' at .1." }
+ end subroutine
+ subroutine f19 ()
+ !$omp declare variant (f1) match(user={condition(}) ! { dg-error "expected expression at .1." }
+ end subroutine
+ subroutine f20 ()
+ !$omp declare variant (f1) match(user={condition()}) ! { dg-error "expected expression at .1." }
+ end subroutine
+ subroutine f21 ()
+ !$omp declare variant (f1) match(user={condition(f1)}) ! { dg-error "expected expression at .1." }
+ end subroutine
+ subroutine f22 ()
+ !$omp declare variant (f1) match(user={condition(1, 2, 3)}) ! { dg-error "expected '\\)' at .1." }
+ end subroutine
+ subroutine f23 ()
+ !$omp declare variant (f1) match(construct={master}) ! { dg-error "selector 'master' not allowed for context selector set 'construct' at .1." }
+ end subroutine
+ subroutine f24 ()
+ !$omp declare variant (f1) match(construct={teams,parallel,master,do}) ! { dg-error "selector 'master' not allowed for context selector set 'construct' at .1." }
+ end subroutine
+ subroutine f25 ()
+ !$omp declare variant (f1) match(construct={parallel(1 ! { dg-error "selector 'parallel' does not accept any properties at .1." }
+ end subroutine
+ subroutine f26 ()
+ !$omp declare variant (f1) match(construct={parallel(1)}) ! { dg-error "selector 'parallel' does not accept any properties at .1." }
+ end subroutine
+ subroutine f27 ()
+ !$omp declare variant (f0) match(construct={simd(12)}) ! { dg-error "expected simd clause at .1." }
+ end subroutine
+ subroutine f32 ()
+ !$omp declare variant (f1) match(device={kind}) ! { dg-error "expected '\\(' at .1." }
+ end subroutine
+ subroutine f33 ()
+ !$omp declare variant (f1) match(device={isa}) ! { dg-error "expected '\\(' at .1." }
+ end subroutine
+ subroutine f34 ()
+ !$omp declare variant (f1) match(device={arch}) ! { dg-error "expected '\\(' at .1." }
+ end subroutine
+ subroutine f35 ()
+ !$omp declare variant (f1) match(device={kind,isa,arch}) ! { dg-error "expected '\\(' at .1." }
+ end subroutine
+ subroutine f36 ()
+ !$omp declare variant (f1) match(device={kind(}) ! { dg-error "expected identifier or string literal at .1." }
+ end subroutine
+ subroutine f39 ()
+ !$omp declare variant (f1) match(device={isa(1)}) ! { dg-error "expected identifier or string literal at .1." }
+ end subroutine
+ subroutine f40 ()
+ !$omp declare variant (f1) match(device={arch(17)}) ! { dg-error "expected identifier or string literal at .1." }
+ end subroutine
+ subroutine f41 ()
+ !$omp declare variant (f1) match(device={foobar(3)})
+ end subroutine
+ subroutine f43 ()
+ !$omp declare variant (f1) match(implementation={foobar(3)})
+ end subroutine
+ subroutine f44 ()
+ !$omp declare variant (f1) match(implementation={vendor}) ! { dg-error "expected '\\(' at .1." }
+ end subroutine
+ subroutine f45 ()
+ !$omp declare variant (f1) match(implementation={extension}) ! { dg-error "expected '\\(' at .1." }
+ end subroutine
+ subroutine f45a ()
+ !$omp declare variant (f1) match(implementation={vendor()}) ! { dg-error "expected identifier or string literal at .1." }
+ end subroutine
+ subroutine f46 ()
+ !$omp declare variant (f1) match(implementation={vendor(123-234)}) ! { dg-error "expected identifier or string literal at .1." }
+ end subroutine
+ subroutine f48 ()
+ !$omp declare variant (f1) match(implementation={unified_address(yes)}) ! { dg-error "selector 'unified_address' does not accept any properties at .1." }
+ end subroutine
+ subroutine f49 ()
+ !$omp declare variant (f1) match(implementation={unified_shared_memory(no)}) ! { dg-error "selector 'unified_shared_memory' does not accept any properties at .1." }
+ end subroutine
+ subroutine f50 ()
+ !$omp declare variant (f1) match(implementation={dynamic_allocators(42)}) ! { dg-error "selector 'dynamic_allocators' does not accept any properties at .1." }
+ end subroutine
+ subroutine f51 ()
+ !$omp declare variant (f1) match(implementation={reverse_offload()}) ! { dg-error "selector 'reverse_offload' does not accept any properties at .1." }
+ end subroutine
+ subroutine f52 ()
+ !$omp declare variant (f1) match(implementation={atomic_default_mem_order}) ! { dg-error "expected '\\('" }
+ end subroutine
+ subroutine f56 ()
+ !$omp declare variant (f1) match(implementation={atomic_default_mem_order(relaxed,seq_cst)}) ! { dg-error "expected '\\)' at .1." }
+ end subroutine
+ subroutine f58 ()
+ !$omp declare variant (f1) match(user={foobar(3)}) ! { dg-error "selector 'foobar' not allowed for context selector set 'user' at .1." }
+ end subroutine
+ subroutine f59 ()
+ !$omp declare variant (f1) match(construct={foobar(3)}) ! { dg-error "selector 'foobar' not allowed for context selector set 'construct' at .1." }
+ end subroutine
+ subroutine f60 ()
+ !$omp declare variant (f1) match(construct={parallel},foobar={bar}) ! { dg-error "expected 'construct', 'device', 'implementation' or 'user' at .1." }
+ end subroutine
+ subroutine f64 ()
+ !$omp declare variant (f1) match(construct={single}) ! { dg-error "selector 'single' not allowed for context selector set 'construct' at .1." }
+ end subroutine
+ subroutine f65 ()
+ !$omp declare variant (f1) match(construct={taskgroup}) ! { dg-error "selector 'taskgroup' not allowed for context selector set 'construct' at .1." }
+ end subroutine
+ subroutine f66 ()
+ !$omp declare variant (f1) match(construct={for}) ! { dg-error "selector 'for' not allowed for context selector set 'construct' at .1." }
+ end subroutine
+ subroutine f67 ()
+ !$omp declare variant (f1) match(construct={threadprivate}) ! { dg-error "selector 'threadprivate' not allowed for context selector set 'construct' at .1." }
+ end subroutine
+ subroutine f68 ()
+ !$omp declare variant (f1) match(construct={critical}) ! { dg-error "selector 'critical' not allowed for context selector set 'construct' at .1." }
+ end subroutine
+ subroutine f69 ()
+ !$omp declare variant (f1) match(construct={task}) ! { dg-error "selector 'task' not allowed for context selector set 'construct' at .1." }
+ end subroutine
+ subroutine f70 ()
+ !$omp declare variant (f1) match(construct={taskloop}) ! { dg-error "selector 'taskloop' not allowed for context selector set 'construct' at .1." }
+ end subroutine
+ subroutine f71 ()
+ !$omp declare variant (f1) match(construct={sections}) ! { dg-error "selector 'sections' not allowed for context selector set 'construct' at .1." }
+ end subroutine
+ subroutine f72 ()
+ !$omp declare variant (f1) match(construct={section}) ! { dg-error "selector 'section' not allowed for context selector set 'construct' at .1." }
+ end subroutine
+ subroutine f73 ()
+ !$omp declare variant (f1) match(construct={workshare}) ! { dg-error "selector 'workshare' not allowed for context selector set 'construct' at .1." }
+ end subroutine
+ subroutine f74 ()
+ !$omp declare variant (f1) match(construct={requires}) ! { dg-error "selector 'requires' not allowed for context selector set 'construct' at .1." }
+ end subroutine
+ subroutine f75 ()
+ !$omp declare variant (f1),match(construct={parallel}) ! { dg-error "expected 'match' at .1." }
+ end subroutine
+ subroutine f76 ()
+ !$omp declare variant (f1) match(implementation={atomic_default_mem_order("relaxed")}) ! { dg-error "expected identifier at .1." }
+ end subroutine
+ subroutine f77 ()
+ !$omp declare variant (f1) match(user={condition(score(f76):1)}) ! { dg-error "score argument must be constant integer expression at .1." }
+ end subroutine
+ subroutine f78 ()
+ !$omp declare variant (f1) match(user={condition(score(-130):1)}) ! { dg-error "score argument must be non-negative" }
+ end subroutine
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-2a.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-2a.f90
new file mode 100644
index 00000000000..56de1177789
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-2a.f90
@@ -0,0 +1,53 @@
+module main
+ implicit none
+contains
+ subroutine f1 ()
+ end subroutine
+ subroutine f28 ()
+ !$omp declare variant (f1) match(construct={parallel},construct={do}) ! { dg-error "selector set 'construct' specified more than once" }
+ end subroutine
+ subroutine f29 ()
+ !$omp declare variant (f1) match(construct={parallel},construct={parallel}) ! { dg-error "selector set 'construct' specified more than once" }
+ end subroutine
+ subroutine f30 ()
+ !$omp declare variant (f1) match(user={condition(0)},construct={target},user={condition(0)}) ! { dg-error "selector set 'user' specified more than once" }
+ end subroutine
+ subroutine f31 ()
+ !$omp declare variant (f1) match(user={condition(0)},user={condition(1)}) ! { dg-error "selector set 'user' specified more than once" }
+ end subroutine
+ subroutine f37 ()
+ !$omp declare variant (f1) match(device={kind(unknown)}) ! { dg-warning "unknown property 'unknown' of 'kind' selector" }
+ end subroutine
+ subroutine f38 ()
+ !$omp declare variant (f1) match(device={kind(unknown,foobar)}) ! { dg-warning "unknown property 'unknown' of 'kind' selector" }
+ ! { dg-warning "unknown property 'foobar' of 'kind' selector" "" { target *-*-* } 22 }
+ end subroutine
+ subroutine f42 ()
+ !$omp declare variant (f1) match(device={arch(x86_64)},device={isa(avx512vl)}) ! { dg-error "selector set 'device' specified more than once" }
+ end subroutine
+ subroutine f47 ()
+ !$omp declare variant (f1) match(implementation={vendor("foobar")}) ! { dg-warning "unknown property '.foobar.' of 'vendor' selector" }
+ end subroutine
+ subroutine f53 ()
+ !$omp declare variant (f1) match(implementation={atomic_default_mem_order(acquire)}) ! { dg-error "incorrect property 'acquire' of 'atomic_default_mem_order' selector" }
+ end subroutine
+ subroutine f54 ()
+ !$omp declare variant (f1) match(implementation={atomic_default_mem_order(release)}) ! { dg-error "incorrect property 'release' of 'atomic_default_mem_order' selector" }
+ end subroutine
+ subroutine f55 ()
+ !$omp declare variant (f1) match(implementation={atomic_default_mem_order(foobar)}) ! { dg-error "incorrect property 'foobar' of 'atomic_default_mem_order' selector" }
+ end subroutine
+ subroutine f57 ()
+ !$omp declare variant (f1) match(implementation={atomic_default_mem_order(relaxed)},&
+ !$omp & implementation={atomic_default_mem_order(relaxed)}) ! { dg-error "selector set 'implementation' specified more than once" "" { target *-*-* } 41 }
+ end subroutine
+ subroutine f61 ()
+ !$omp declare variant (f1) match(construct={parallel,parallel}) ! { dg-error "selector 'parallel' specified more than once in set 'construct'" }
+ end subroutine
+ subroutine f62 ()
+ !$omp declare variant (f1) match(construct={target,parallel,do,simd,parallel}) ! { dg-error "selector 'parallel' specified more than once in set 'construct'" }
+ end subroutine
+ subroutine f63 ()
+ !$omp declare variant (f1) match(construct={target,teams,teams}) ! { dg-error "selector 'teams' specified more than once in set 'construct'" }
+ end subroutine
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-3.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-3.f90
new file mode 100644
index 00000000000..c62622b607b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-3.f90
@@ -0,0 +1,237 @@
+module main
+contains
+ subroutine f1 ()
+ end subroutine
+ subroutine f2 ()
+ !$omp declare variant (f1) match (construct={target})
+ end subroutine
+ subroutine f3 ()
+ end subroutine
+ subroutine f4 ()
+ !$omp declare variant (f3) match (construct={teams})
+ end subroutine
+ subroutine f5 ()
+ end subroutine
+ subroutine f6 ()
+ !$omp declare variant (f5) match (construct={parallel})
+ end subroutine
+ subroutine f7 ()
+ end subroutine
+ subroutine f8 ()
+ !$omp declare variant (f7) match (construct={do})
+ end subroutine
+ subroutine f9 ()
+ end subroutine
+ subroutine f10 ()
+ !$omp declare variant (f9) match (construct={target,teams,parallel,do})
+ end subroutine
+ subroutine f11 ()
+ end subroutine
+ subroutine f12 ()
+ !$omp declare variant (f11) match (construct={teams,do,parallel})
+ end subroutine
+ subroutine f13 ()
+ end subroutine
+ subroutine f14 ()
+ !$omp declare variant (f13) match (device={kind(any)})
+ end subroutine
+ subroutine f15 ()
+ !$omp declare variant (f13) match (device={kind("host")})
+ end subroutine
+ subroutine f16 ()
+ !$omp declare variant (f13) match (device={kind(nohost)})
+ end subroutine
+ subroutine f17 ()
+ !$omp declare variant (f13) match (device={kind(cpu)})
+ end subroutine
+ subroutine f18 ()
+ !$omp declare variant (f13) match (device={kind("gpu")})
+ end subroutine
+ subroutine f19 ()
+ !$omp declare variant (f13) match (device={kind(fpga)})
+ end subroutine
+ subroutine f20 ()
+ !$omp declare variant (f13) match (device={kind(any,any)})
+ end subroutine
+ subroutine f21 ()
+ !$omp declare variant (f13) match (device={kind(host,nohost)})
+ end subroutine
+ subroutine f22 ()
+ !$omp declare variant (f13) match (device={kind("cpu","gpu","fpga")})
+ end subroutine
+ subroutine f23 ()
+ !$omp declare variant (f13) match (device={kind(any,cpu,nohost)})
+ end subroutine
+ subroutine f24 ()
+ !$omp declare variant (f13) match (device={isa(avx)})
+ end subroutine
+ subroutine f25 ()
+ !$omp declare variant (f13) match (device={isa(sse4,"avx512f",avx512vl,avx512bw)})
+ end subroutine
+ subroutine f26 ()
+ !$omp declare variant (f13) match (device={arch("x86_64")})
+ end subroutine
+ subroutine f27 ()
+ !$omp declare variant (f13) match (device={arch(riscv64)})
+ end subroutine
+ subroutine f28 ()
+ !$omp declare variant (f13) match (device={arch(nvptx)})
+ end subroutine
+ subroutine f29 ()
+ !$omp declare variant (f13) match (device={arch(x86_64),isa("avx512f","avx512vl"),kind(cpu)})
+ end subroutine
+ subroutine f30 ()
+ !$omp declare variant (f13) match (implementation={vendor(amd)})
+ end subroutine
+ subroutine f31 ()
+ !$omp declare variant (f13) match (implementation={vendor(arm)})
+ end subroutine
+ subroutine f32 ()
+ !$omp declare variant (f13) match (implementation={vendor("bsc")})
+ end subroutine
+ subroutine f33 ()
+ !$omp declare variant (f13) match (implementation={vendor(cray)})
+ end subroutine
+ subroutine f34 ()
+ !$omp declare variant (f13) match (implementation={vendor(fujitsu)})
+ end subroutine
+ subroutine f35 ()
+ !$omp declare variant (f13) match (implementation={vendor(gnu)})
+ end subroutine
+ subroutine f36 ()
+ !$omp declare variant (f13) match (implementation={vendor(ibm)})
+ end subroutine
+ subroutine f37 ()
+ !$omp declare variant (f13) match (implementation={vendor("intel")})
+ end subroutine
+ subroutine f38 ()
+ !$omp declare variant (f13) match (implementation={vendor(llvm)})
+ end subroutine
+ subroutine f39 ()
+ !$omp declare variant (f13) match (implementation={vendor(pgi)})
+ end subroutine
+ subroutine f40 ()
+ !$omp declare variant (f13) match (implementation={vendor(ti)})
+ end subroutine
+ subroutine f41 ()
+ !$omp declare variant (f13) match (implementation={vendor(unknown)})
+ end subroutine
+ subroutine f42 ()
+ !$omp declare variant (f13) match (implementation={vendor(gnu,llvm,intel,ibm)})
+ end subroutine
+ subroutine f43 ()
+ !$omp declare variant (f13) match (implementation={extension(my_cute_extension)}) ! { dg-warning "unknown property 'my_cute_extension' of 'extension' selector" }
+ end subroutine
+ subroutine f44 ()
+ !$omp declare variant (f13) match (implementation={extension(some_other_ext,another_ext)}) ! { dg-warning "unknown property 'some_other_ext' of 'extension' selector" }
+ ! { dg-warning "unknown property 'another_ext' of 'extension' selector" "" { target *-*-* } .-1 }
+ end subroutine
+ subroutine f45 ()
+ !$omp declare variant (f13) match (implementation={unified_shared_memory})
+ end subroutine
+ subroutine f46 ()
+ !$omp declare variant (f13) match (implementation={unified_address})
+ end subroutine
+ subroutine f47 ()
+ !$omp declare variant (f13) match (implementation={dynamic_allocators})
+ end subroutine
+ subroutine f48 ()
+ !$omp declare variant (f13) match (implementation={reverse_offload})
+ end subroutine
+ subroutine f49 ()
+ !$omp declare variant (f13) match (implementation={atomic_default_mem_order(seq_cst)})
+ end subroutine
+ subroutine f50 ()
+ !$omp declare variant (f13) match (implementation={atomic_default_mem_order(relaxed)})
+ end subroutine
+ subroutine f51 ()
+ !$omp declare variant (f13) match (implementation={atomic_default_mem_order(acq_rel)})
+ end subroutine
+ subroutine f52 ()
+ !$omp declare variant (f14) match (implementation={atomic_default_mem_order(acq_rel),vendor(gnu),&
+ !$omp& unified_address,extension(foobar)}) ! { dg-warning "unknown property 'foobar' of 'extension' selector" "" { target *-*-* } .-1 }
+ end subroutine
+ subroutine f53 ()
+ !$omp declare variant (f13) match (implementation={vendor(score(3):amd)})
+ end subroutine
+ subroutine f54 ()
+ !$omp declare variant (f13) match (implementation={vendor(score(4):"arm")})
+ end subroutine
+ subroutine f55 ()
+ !$omp declare variant (f13) match (implementation={vendor(score(5):bsc)})
+ end subroutine
+ subroutine f56 ()
+ !$omp declare variant (f13) match (implementation={vendor(score(6):cray)})
+ end subroutine
+ subroutine f57 ()
+ !$omp declare variant (f13) match (implementation={vendor(score(7):fujitsu)})
+ end subroutine
+ subroutine f58 ()
+ !$omp declare variant (f13) match (implementation={vendor(score(8):gnu)})
+ end subroutine
+ subroutine f59 ()
+ !$omp declare variant (f13) match (implementation={vendor(score(9):ibm)})
+ end subroutine
+ subroutine f60 ()
+ !$omp declare variant (f13) match (implementation={vendor(score(10):intel)})
+ end subroutine
+ subroutine f61 ()
+ !$omp declare variant (f13) match (implementation={vendor(score(11):llvm)})
+ end subroutine
+ subroutine f62 ()
+ !$omp declare variant (f13) match (implementation={vendor(score(12):pgi)})
+ end subroutine
+ subroutine f63 ()
+ !$omp declare variant (f13) match (implementation={vendor(score(13):"ti")})
+ end subroutine
+ subroutine f64 ()
+ !$omp declare variant (f13) match (implementation={vendor(score(14):unknown)})
+ end subroutine
+ subroutine f65 ()
+ !$omp declare variant (f13) match (implementation={vendor(score(15):gnu,llvm,intel,ibm)})
+ end subroutine
+ subroutine f66 ()
+ !$omp declare variant (f13) match (implementation={extension(score(16):my_cute_extension)}) ! { dg-warning "unknown property 'my_cute_extension' of 'extension' selector" }
+ end subroutine
+ subroutine f67 ()
+ !$omp declare variant (f13) match (implementation={extension(score(17):some_other_ext,another_ext)}) ! { dg-warning "unknown property 'some_other_ext' of 'extension' selector" }
+ end subroutine ! { dg-warning "unknown property 'another_ext' of 'extension' selector" "" { target *-*-* } .-1 }
+ subroutine f68 ()
+ !$omp declare variant (f13) match (implementation={atomic_default_mem_order(score(18):seq_cst)})
+ end subroutine
+ subroutine f69 ()
+ !$omp declare variant (f13) match (implementation={atomic_default_mem_order(score(19):relaxed)})
+ end subroutine
+ subroutine f70 ()
+ !$omp declare variant (f13) match (implementation={atomic_default_mem_order(score(20):acq_rel)})
+ end subroutine
+ subroutine f71 ()
+ !$omp declare variant (f13) match (implementation={atomic_default_mem_order(score(21):acq_rel),&
+ !$omp& vendor(score(22):gnu),unified_address,extension(score(22):foobar)}) ! { dg-warning "unknown property 'foobar' of 'extension' selector" "" { target *-*-* } .-1 }
+ end subroutine
+ subroutine f72 ()
+ !$omp declare variant (f13) match (user={condition(0)})
+ end subroutine
+ subroutine f73 ()
+ !$omp declare variant (f13) match (user={condition(272-272*1)})
+ end subroutine
+ subroutine f74 ()
+ !$omp declare variant (f13) match (user={condition(score(25):1)})
+ end subroutine
+ subroutine f75 ()
+ !$omp declare variant (f13) match (device={kind(any,"any")})
+ end subroutine
+ subroutine f76 ()
+ !$omp declare variant (f13) match (device={kind("any","any")})
+ end subroutine
+ subroutine f77 ()
+ !$omp declare variant (f13) match (device={kind("any",any)})
+ end subroutine
+ subroutine f78 ()
+ !$omp declare variant (f13) match (implementation={vendor(nvidia)})
+ end subroutine
+ subroutine f79 ()
+ !$omp declare variant (f13) match (user={condition(score(0):0)})
+ end subroutine
+
+ end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-4.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-4.f90
new file mode 100644
index 00000000000..bc4f41647b4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-4.f90
@@ -0,0 +1,62 @@
+program main
+ implicit none
+contains
+ function f6 (x, y, z)
+ real (kind = 8) :: f6
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real (kind = 4), intent(in) :: z
+
+ interface
+ function f1 (x, y, z)
+ real (kind = 8) :: f1
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real (kind = 4), intent(in) :: z
+ end function
+
+ function f2 (x, y, z)
+ real (kind = 8) :: f2
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real (kind = 4), intent(in) :: z
+ end function
+
+ function f3 (x, y, z)
+ real (kind = 8) :: f3
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real (kind = 4), intent(in) :: z
+ end function
+
+ function f4 (x, y, z)
+ real (kind = 8) :: f4
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real (kind = 4), intent(in) :: z
+ end function
+
+ function f5 (x, y, z)
+ real (kind = 8) :: f5
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real (kind = 4), intent(in) :: z
+ end function
+ end interface
+
+ !$omp declare variant (f1) match (user={condition(1)})
+ !$omp declare variant (f2) match (user={condition(score(1):1)})
+ !$omp declare variant (f3) match (user={condition(score(3):1)})
+ !$omp declare variant (f4) match (user={condition(score(2):1)})
+ !$omp declare variant (f5) match (implementation={vendor(gnu)})
+
+ f6 = z + x + y
+ end function
+
+ function test (x)
+ real (kind = 8) :: test
+ integer, intent(in) :: x
+
+ test = f6 (x, int (x, kind = 8), 3.5)
+ end function
+end program
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-5.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-5.f90
new file mode 100644
index 00000000000..ad7acb9842d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-5.f90
@@ -0,0 +1,75 @@
+! { dg-do compile { target i?86-*-* x86_64-*-* } }
+! { dg-additional-options "-mavx2" }
+
+module main
+ implicit none
+contains
+ function f1 (x, y, z)
+ integer, dimension(4) :: f1
+ real, dimension(4), intent(in) :: x, y
+ real, intent(out) :: z
+
+ f1 = x
+ end function
+
+ function f2 (x, y, z)
+ integer, dimension(8) :: f2
+ real, dimension(8), intent(in) :: x, y
+ real, intent(out) :: z
+
+ f2 = x
+ end function
+
+ function f3 (x, y, z)
+ integer, dimension(4) :: f3
+ real, dimension(4), intent(in) :: x, z
+ integer, intent(in) :: y
+
+ f3 = x
+ end function
+
+ integer function f4 (x, y, z)
+ real, intent(in) :: x, y
+ real, intent(out) :: z
+ !$omp declare variant (f1) match (construct={parallel,do,simd(simdlen(4),notinbranch,uniform(z),aligned(z:16))})
+ !$omp declare variant (f2) match (construct={do,simd(uniform(z),simdlen(8),notinbranch)})
+ end function
+
+ integer function f5 (x, y)
+ integer, intent(in) :: x, y
+ !$omp declare variant (f3) match (construct={simd(simdlen(4),inbranch,linear(y:1))})
+ end function
+
+ subroutine test (x, y, z, w)
+ integer, dimension(8192), intent(inout) :: x
+ real, dimension(8192), intent(inout) :: y, z
+ real, pointer, intent(out) :: w
+ integer :: i
+
+ !$omp parallel
+ !$omp do simd aligned (w:16)
+ do i = 1, 1024
+ x(i) = f4 (y(i), z(i), w)
+ end do
+ !$omp end do simd
+ !$omp end parallel
+
+ !$omp parallel do simd aligned (w:16) simdlen(4)
+ do i = 1025, 2048
+ x(i) = f4 (y(i), z(i), w)
+ end do
+ !$omp end parallel do simd
+
+ !$omp simd aligned (w:16)
+ do i = 2049, 4096
+ x(i) = f4 (y(i), z(i), w)
+ end do
+ !$omp end simd
+
+ !$omp simd
+ do i = 4097, 8192
+ if (x(i) .gt. 10) x(i) = f5 (x(i), i)
+ end do
+ !$omp end simd
+ end subroutine
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-6.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-6.f90
new file mode 100644
index 00000000000..3f33f38b9bc
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-6.f90
@@ -0,0 +1,188 @@
+module main
+ implicit none
+contains
+ function f1 (x, y, z)
+ real (kind = 8) :: f1
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+
+ f1 = 0.0
+ end function
+
+ function f2 (x, y, z)
+ real (kind = 8) :: f2
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+
+ f2 = 0.0
+ end function
+
+ function f3 (x, y, z)
+ real (kind = 8) :: f3
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ !$omp declare variant (f1) match (user={condition(0)},construct={parallel})
+ f3 = 0.0
+ end function
+
+ function f4 (x, y, z)
+ real (kind = 8) :: f4
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ !$omp declare variant (f1) match (construct={parallel},user={condition(score(1):1)})
+ f4 = 0.0
+ end function
+
+ function f5 (x, y, z)
+ real (kind = 8) :: f5
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ f5 = 0.0
+ end function
+
+ function f6 (x, y, z)
+ real (kind = 8) :: f6
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ !$omp declare variant (f5) match (user={condition(0)}) ! { dg-error "'f5' used as a variant with incompatible 'construct' selector sets" }
+ f6 = 0.0
+ end function
+
+ function f7 (x, y, z)
+ real (kind = 8) :: f7
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ !$omp declare variant (f5) match (construct={parallel},user={condition(score(1):1)})
+ f7 = 0.0
+ end function
+
+ function f8 (x, y, z)
+ real (kind = 8) :: f8
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ f8 = 0.0
+ end function
+
+ function f9 (x, y, z)
+ real (kind = 8) :: f9
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ !$omp declare variant (f8) match (user={condition(0)},construct={do}) ! { dg-error "'f8' used as a variant with incompatible 'construct' selector sets" }
+ f9 = 0.0
+ end function
+
+ function f10 (x, y, z)
+ real (kind = 8) :: f10
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ !$omp declare variant (f8) match (user={condition(1)})
+ f10 = 0.0
+ end function
+
+ function f11 (x, y, z)
+ real (kind = 8) :: f11
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ f11 = 0.0
+ end function
+
+ function f12 (x, y, z)
+ real (kind = 8) :: f12
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ !$omp declare variant (f11) match (construct={target,teams,parallel,do}) ! { dg-error "'f11' used as a variant with incompatible 'construct' selector sets" }
+ f12 = 0.0
+ end function
+
+ function f13 (x, y, z)
+ real (kind = 8) :: f13
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ !$omp declare variant (f11) match (user={condition(score(1):1)},construct={target,teams,parallel,do}) ! { dg-error "'f11' used as a variant with incompatible 'construct' selector sets" }
+ f13 = 0.0
+ end function
+
+ function f14 (x, y, z)
+ real (kind = 8) :: f14
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ !$omp declare variant (f11) match (implementation={vendor(gnu)},construct={target,teams,parallel}) ! { dg-error "'f11' used as a variant with incompatible 'construct' selector sets" }
+ f14 = 0.0
+ end function
+
+ function f15 (x, y, z)
+ real (kind = 8) :: f15
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ !$omp declare variant (f11) match (device={kind(any)},construct={teams,parallel})
+ f15 = 0.0
+ end function
+
+ function f16 (x, y, z)
+ real (kind = 8) :: f16
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ f16 = 0.0
+ end function
+
+ function f17 (x, y, z)
+ real (kind = 8) :: f17
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ !$omp declare variant (f16) match (construct={teams,parallel}) ! { dg-error "'f16' used as a variant with incompatible 'construct' selector sets" }
+ f17 = 0.0
+ end function
+
+ function f18 (x, y, z)
+ real (kind = 8) :: f18
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ !$omp declare variant (f16) match(construct={teams,parallel,do})
+ f18 = 0.0
+ end function
+
+ function f19 (x, y, z)
+ real (kind = 8) :: f19
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ f19 = 0.0
+ end function
+
+ function f20 (x, y, z)
+ real (kind = 8) :: f20
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ !$omp declare variant (f19) match (construct={parallel}) ! { dg-error "'f19' used as a variant with incompatible 'construct' selector sets" }
+ f20 = 0.0
+ end function
+
+ function f21 (x, y, z)
+ real (kind = 8) :: f21
+ integer, intent(in) :: x
+ integer (kind = 8), intent(in) :: y
+ real :: z
+ !$omp declare variant (f19) match (construct={do},implementation={vendor(gnu,llvm)})
+ f21 = 0.0
+ end function
+
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-7.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-7.f90
new file mode 100644
index 00000000000..1590a2a26f0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-7.f90
@@ -0,0 +1,93 @@
+! { dg-do compile { target i?86-*-* x86_64-*-* } }
+! { dg-additional-options "-mavx2" }
+
+module main
+ implicit none
+contains
+ function f1 (x, y, z)
+ integer, dimension(4) :: f1
+ real, dimension(4), intent(in) :: x, y
+ real, intent(out) :: z
+
+ f1 = x
+ end function
+
+ function f2 (x, y, z)
+ integer, dimension(8) :: f2
+ real, dimension(8), intent(in) :: x, y
+ real, intent(out) :: z
+
+ f2 = x
+ end function
+
+ function f3 (x, y, z)
+ integer, dimension(4) :: f3
+ real, dimension(4), intent(in) :: x, z
+ integer, intent(in) :: y
+
+ f3 = x
+ end function
+
+ integer function f4 (x, y, z)
+ real, intent(in) :: x, y
+ real, pointer, intent(out) :: z
+ !$omp declare variant (f1) match (construct={parallel,do,simd(simdlen(4),notinbranch,uniform(z),aligned(z:16))}) ! { dg-error "'f1' used as a variant with incompatible 'construct' selector sets" }
+ end function
+
+ integer function f5 (u, v, w)
+ real, intent(in) :: u, v
+ real, pointer, intent(out) :: w
+ !$omp declare variant (f1) match (construct={parallel,do,simd(uniform(w),simdlen(8*2-12),aligned(w:16),notinbranch)}) ! { dg-error "'f1' used as a variant with incompatible 'construct' selector sets" }
+ end function
+
+ integer function f6 (u, v, w)
+ real, intent(in) :: u, v
+ real, pointer, intent(out) :: w
+ !$omp declare variant (f1) match (construct={parallel,do,simd(linear(w),notinbranch,simdlen(4),aligned(w:16))}) ! { dg-error "'f1' used as a variant with incompatible 'construct' selector sets" }
+ end function
+
+ integer function f7 (u, v, w)
+ real, intent(in) :: u, v
+ real, pointer, intent(out) :: w
+ !$omp declare variant (f1) match (construct={parallel,do,simd(uniform(w),notinbranch,simdlen(4),aligned(w:8))}) ! { dg-error "'f1' used as a variant with incompatible 'construct' selector sets" }
+ end function
+
+ integer function f8 (u, v, w)
+ real, intent(in) :: u, v
+ real, pointer, intent(out) :: w
+ !$omp declare variant (f1) match (construct={parallel,do,simd(uniform(w),notinbranch,simdlen(4),aligned(w))})
+ end function
+
+ integer function f9 (x, y, z)
+ real, intent(in) :: x, y
+ real, pointer, intent(out) :: z
+ !$omp declare variant (f2) match (construct={do,simd(uniform(z),simdlen(8),notinbranch)}) ! { dg-error "'f2' used as a variant with incompatible 'construct' selector sets" }
+ end function
+
+ integer function f10 (x, y, q)
+ real, intent(in) :: x, y
+ real, pointer, intent(out) :: q
+ !$omp declare variant (f2) match (construct={do,simd(notinbranch,simdlen(2+2+4),uniform (q))}) ! { dg-error "'f2' used as a variant with incompatible 'construct' selector sets" }
+ end function
+
+ integer function f11 (x, y, z)
+ real, intent(in) :: x, y
+ real, pointer, intent(out) :: z
+ !$omp declare variant (f2) match (construct={do,simd(linear(z:2),simdlen(8),notinbranch)})
+ end function
+
+ integer function f12 (x, y)
+ integer, intent(in) :: x, y
+ !$omp declare variant (f3) match (construct={simd(simdlen(4),inbranch,linear(y:1))}) ! { dg-error "'f3' used as a variant with incompatible 'construct' selector sets" }
+ end function
+
+ integer function f13 (x, q)
+ integer, intent(in) :: x, q
+ !$omp declare variant (f3) match (construct={simd(inbranch, simdlen (5-1), linear (q:4-3))}) ! { dg-error "'f3' used as a variant with incompatible 'construct' selector sets" }
+ end function
+
+ integer function f14 (x, q)
+ integer, intent(in) :: x, q
+ !$omp declare variant (f3) match (construct={simd(inbranch,simdlen(4),linear(q:2))})
+ end function
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-8.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-8.f90
new file mode 100644
index 00000000000..c751489a5db
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-8.f90
@@ -0,0 +1,218 @@
+! { dg-do compile }
+! { dg-additional-options "-fdump-tree-gimple" }
+
+program main
+ !$omp requires atomic_default_mem_order(seq_cst)
+ !$omp declare target to (test3)
+contains
+ subroutine f01 ()
+ end subroutine
+
+ subroutine f02 ()
+ !$omp declare variant (f01) match (user={condition(6 == 7)},implementation={vendor(gnu)})
+ end subroutine
+
+ subroutine f03 ()
+ end subroutine
+
+ subroutine f04 ()
+ !$omp declare variant (f03) match (user={condition(6 == 6)},implementation={atomic_default_mem_order(seq_cst)})
+ end subroutine
+
+ subroutine f05 ()
+ end subroutine
+
+ subroutine f06 ()
+ !$omp declare variant (f05) match (user={condition(1)},implementation={atomic_default_mem_order(relaxed)})
+ end subroutine
+
+ subroutine f07 ()
+ end subroutine
+
+ subroutine f08 ()
+ !$omp declare variant (f07) match (construct={parallel,do},device={kind("any")})
+ end subroutine
+
+ subroutine f09 ()
+ end subroutine
+
+ subroutine f10 ()
+ !$omp declare variant (f09) match (construct={parallel,do},implementation={vendor("gnu")})
+ end subroutine
+
+ subroutine f11 ()
+ end subroutine
+
+ subroutine f12 ()
+ !$omp declare variant (f11) match (construct={parallel,do})
+ end subroutine
+
+ subroutine f13 ()
+ end subroutine
+
+ subroutine f14 ()
+ !$omp declare variant (f13) match (construct={parallel,do})
+ end subroutine
+
+ subroutine f15 ()
+ !$omp declare target to (f13, f14)
+ end subroutine
+
+ subroutine f16 ()
+ !$omp declare variant (f15) match (implementation={vendor(llvm)})
+ end subroutine
+
+ subroutine f17 ()
+ end subroutine
+
+ subroutine f18 ()
+ !$omp declare variant (f17) match (construct={target,parallel})
+ end subroutine
+
+ subroutine f19 ()
+ end subroutine
+
+ subroutine f20 ()
+ !$omp declare variant (f19) match (construct={target,parallel})
+ end subroutine
+
+ subroutine f22 ()
+ !$omp declare variant (f21) match (construct={teams,parallel})
+ end subroutine
+
+ subroutine f23 ()
+ end subroutine
+
+ subroutine f24 ()
+ !$omp declare variant (f23) match (construct={teams,parallel,do})
+ end subroutine
+
+ subroutine f25 ()
+ end subroutine
+
+ subroutine f27 ()
+ end subroutine
+
+ subroutine f28 ()
+ !$omp declare variant (f27) match (construct={teams,parallel,do})
+ end subroutine
+
+ subroutine f30 ()
+ !$omp declare variant (f29) match (implementation={vendor(gnu)})
+ end subroutine
+
+ subroutine f31 ()
+ end subroutine
+
+ subroutine f32 ()
+ !$omp declare variant (f31) match (construct={teams,parallel,do})
+ end subroutine
+
+ subroutine f33 ()
+ end subroutine
+
+ subroutine f34 ()
+ !$omp declare variant (f33) match (device={kind("any\0any")}) ! { dg-warning "unknown property '.any..0any.' of 'kind' selector" }
+ end subroutine
+
+ subroutine f35 ()
+ end subroutine
+
+ subroutine f36 ()
+ !$omp declare variant (f35) match (implementation={vendor("gnu\0")}) ! { dg-warning "unknown property '.gnu..0.' of 'vendor' selector" }
+ end subroutine
+
+ subroutine test1 ()
+ integer :: i
+
+ call f02 () ! { dg-final { scan-tree-dump-times "f02 \\\(\\\);" 1 "gimple" } }
+ call f04 () ! { dg-final { scan-tree-dump-times "f03 \\\(\\\);" 1 "gimple" } }
+ call f06 () ! { dg-final { scan-tree-dump-times "f06 \\\(\\\);" 1 "gimple" } }
+
+ !$omp parallel
+ !$omp do
+ do i = 1, 2
+ call f08 () ! { dg-final { scan-tree-dump-times "f07 \\\(\\\);" 1 "gimple" } }
+ end do
+ !$omp end do
+ !$omp end parallel
+
+ !$omp parallel do
+ do i = 1, 2
+ call f10 () ! { dg-final { scan-tree-dump-times "f09 \\\(\\\);" 1 "gimple" } }
+ end do
+ !$omp end parallel do
+
+ !$omp do
+ do i = 1, 2
+ !$omp parallel
+ call f12 () ! { dg-final { scan-tree-dump-times "f12 \\\(\\\);" 1 "gimple" } }
+ !$omp end parallel
+ end do
+ !$omp end do
+
+ !$omp parallel
+ !$omp target
+ !$omp do
+ do i = 1, 2
+ call f14 () ! { dg-final { scan-tree-dump-times "f14 \\\(\\\);" 1 "gimple" } }
+ end do
+ !$omp end do
+ !$omp end target
+ !$omp end parallel
+
+ call f16 () ! { dg-final { scan-tree-dump-times "f16 \\\(\\\);" 1 "gimple" } }
+ call f34 () ! { dg-final { scan-tree-dump-times "f34 \\\(\\\);" 1 "gimple" } }
+ call f36 () ! { dg-final { scan-tree-dump-times "f36 \\\(\\\);" 1 "gimple" } }
+ end subroutine
+
+ subroutine test2 ()
+ ! OpenMP 5.0 specifies that the 'target' trait should be added for
+ ! functions within a declare target block, but Fortran does not have
+ ! the notion of a declare target _block_, so the variant is not used here.
+ ! This may change in later versions of OpenMP.
+
+ !$omp declare target
+ !$omp parallel
+ call f18 () ! { dg-final { scan-tree-dump-times "f18 \\\(\\\);" 1 "gimple" } }
+ !$omp end parallel
+ end subroutine
+
+ subroutine test3 ()
+ ! In the C version, this test was used to check that the
+ ! 'declare target to' form of the directive did not result in the variant
+ ! being used.
+ !$omp parallel
+ call f20 () ! { dg-final { scan-tree-dump-times "f20 \\\(\\\);" 1 "gimple" } }
+ !$omp end parallel
+ end subroutine
+
+ subroutine f21 ()
+ integer :: i
+ !$omp do
+ do i = 1, 2
+ call f24 () ! { dg-final { scan-tree-dump-times "f23 \\\(\\\);" 1 "gimple" } }
+ end do
+ !$omp end do
+ end subroutine
+
+ subroutine f26 ()
+ !$omp declare variant (f25) match (construct={teams,parallel})
+
+ integer :: i
+ !$omp do
+ do i = 1, 2
+ call f28 () ! { dg-final { scan-tree-dump-times "f28 \\\(\\\);" 1 "gimple" } }
+ end do
+ !$omp end do
+ end subroutine
+
+ subroutine f29 ()
+ integer :: i
+ !$omp do
+ do i = 1, 2
+ call f32 () ! { dg-final { scan-tree-dump-times "f32 \\\(\\\);" 1 "gimple" } }
+ end do
+ !$omp end do
+ end subroutine
+end program
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-9.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-9.f90
new file mode 100644
index 00000000000..ebd066609f3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-9.f90
@@ -0,0 +1,58 @@
+! { dg-do compile }
+! { dg-additional-options "-cpp -fdump-tree-gimple" }
+! { dg-additional-options "-mno-sse3" { target { i?86-*-* x86_64-*-* } } }
+
+program main
+ implicit none
+contains
+ subroutine f01 ()
+ end subroutine
+ subroutine f02 ()
+ !$omp declare variant (f01) match (device={isa("avx512f",avx512bw)})
+ end subroutine
+ subroutine f05 ()
+ end subroutine
+ subroutine f06 ()
+ !$omp declare variant (f05) match (device={kind(gpu)})
+ end subroutine
+ subroutine f07 ()
+ end subroutine
+ subroutine f08 ()
+ !$omp declare variant (f07) match (device={kind("cpu")})
+ end subroutine
+ subroutine f09 ()
+ end subroutine
+ subroutine f10 ()
+ !$omp declare variant (f09) match (device={isa(sm_35)})
+ end subroutine
+ subroutine f11 ()
+ end subroutine
+ subroutine f12 ()
+ !$omp declare variant (f11) match (device={arch(nvptx)})
+ end subroutine
+ subroutine f13 ()
+ end subroutine
+ subroutine f14 ()
+ !$omp declare variant (f13) match (device={arch("i386"),isa(sse4)})
+ end subroutine
+ subroutine f17 ()
+ end subroutine
+ subroutine f18 ()
+ !$omp declare variant (f17) match (device={kind("any","fpga")})
+ end subroutine
+
+ subroutine test1 ()
+ integer :: i;
+ call f02 () ! { dg-final { scan-tree-dump-times "f02 \\\(\\\);" 1 "gimple" } }
+ call f14 () ! { dg-final { scan-tree-dump-times "f14 \\\(\\\);" 1 "gimple" } }
+ call f18 () ! { dg-final { scan-tree-dump-times "f18 \\\(\\\);" 1 "gimple" } }
+ end subroutine
+
+ subroutine test3 ()
+ call f06 () ! { dg-final { scan-tree-dump-times "f06 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* amdgcn*-*-* } } } } }
+ call f08 () ! { dg-final { scan-tree-dump-times "f07 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* amdgcn*-*-* } } } } }
+ call f10 () ! { dg-final { scan-tree-dump-times "f10 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* amdgcn*-*-* } } } } }
+ call f12 () ! { dg-final { scan-tree-dump-times "f12 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* } } } } }
+ ! { dg-final { scan-tree-dump-times "f11 \\\(\\\);" 1 "gimple" { target { nvptx*-*-* } } } }
+ end subroutine
+end program
diff --git a/libgomp/testsuite/libgomp.fortran/declare-variant-1.f90 b/libgomp/testsuite/libgomp.fortran/declare-variant-1.f90
new file mode 100644
index 00000000000..e6f69dccb49
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/declare-variant-1.f90
@@ -0,0 +1,33 @@
+! { dg-do run }
+
+program main
+ implicit none
+
+ integer :: v
+ !$omp target map(from:v)
+ v = on ()
+ !$omp end target
+
+ select case (v)
+ case default
+ write (*,*) "Host fallback or unknown offloading"
+ case (1)
+ write (*,*) "Offloading to NVidia PTX"
+ case (2)
+ write (*,*) "Offloading to AMD GCN"
+ end select
+contains
+ integer function on_nvptx ()
+ on_nvptx = 1
+ end function
+
+ integer function on_gcn ()
+ on_gcn = 2
+ end function
+
+ integer function on ()
+ !$omp declare variant (on_nvptx) match(construct={target},device={arch(nvptx)})
+ !$omp declare variant (on_gcn) match(construct={target},device={arch(gcn)})
+ on = 0
+ end function
+end program
On Thu, Oct 14, 2021 at 11:04:59AM +0100, Kwok Cheung Yeung wrote:
> I have now dropped this. This affects test2 in
> gfortran.dg/gomp/declare-variant-8.f90, which I have added a comment to.
Thanks.
> I have added Fortran-specific tests as
> gfortran.dg/gomp/declare-variant-15.f90 to declare-variant-19.f90.
What I still miss is tests for the (proc_name : variant_name) syntax
in places where proc_name : is optional, but is supplied and is valid, like
e.g. in interface, or in subroutine/function and where proc_name specifies
the name of the containing interface or subroutine/function.
I see that syntax tested in some places with dg-error on that line and
in spaces where it isn't optional (e.g. at module scope before contains).
But if you want, that can be added incrementally.
> From ab03cf08c6ee4a0a6323189313cae911483a2257 Mon Sep 17 00:00:00 2001
> From: Kwok Cheung Yeung <kcy@codesourcery.com>
> Date: Wed, 13 Oct 2021 22:39:20 +0100
> Subject: [PATCH] openmp, fortran: Add support for OpenMP declare variant
> directive in Fortran
>
> 2021-10-13 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.
LGTM, thanks.
Jakub
On 14/10/2021 1:47 pm, Jakub Jelinek wrote:
> What I still miss is tests for the (proc_name : variant_name) syntax
> in places where proc_name : is optional, but is supplied and is valid, like
> e.g. in interface, or in subroutine/function and where proc_name specifies
> the name of the containing interface or subroutine/function.
> I see that syntax tested in some places with dg-error on that line and
> in spaces where it isn't optional (e.g. at module scope before contains).
> But if you want, that can be added incrementally.
Do you mean something like these tests?
Thanks
Kwok
From 38733234024697d2144613c4a992e970f40afad8 Mon Sep 17 00:00:00 2001
From: Kwok Cheung Yeung <kcy@codesourcery.com>
Date: Mon, 18 Oct 2021 13:56:59 -0700
Subject: [PATCH] openmp: Add additional tests for declare variant in Fortran
Add tests to check that explicitly specifying the containing procedure as the
base name for declare variant works.
2021-10-18 Kwok Cheung Yeung <kcy@codesourcery.com>
gcc/testsuite/
* gfortran.dg/gomp/declare-variant-15.f90 (variant2, base2, test2):
Add tests.
* gfortran.dg/gomp/declare-variant-16.f90 (base2, variant2, test2):
Add tests.
---
.../gfortran.dg/gomp/declare-variant-15.f90 | 13 +++++++++++++
.../gfortran.dg/gomp/declare-variant-16.f90 | 14 +++++++++++++-
2 files changed, 26 insertions(+), 1 deletion(-)
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-15.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-15.f90
index b2ad96a8998..4a88e3e46c7 100644
--- a/gcc/testsuite/gfortran.dg/gomp/declare-variant-15.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-15.f90
@@ -14,6 +14,13 @@ contains
subroutine base ()
end subroutine
+ subroutine variant2 ()
+ end subroutine
+
+ subroutine base2 ()
+ !$omp declare variant (base2: variant2) match (construct={parallel})
+ end subroutine
+
subroutine test1 ()
!$omp target
!$omp parallel
@@ -21,4 +28,10 @@ contains
!$omp end parallel
!$omp end target
end subroutine
+
+ subroutine test2 ()
+ !$omp parallel
+ call base2 () ! { dg-final { scan-tree-dump-times "variant2 \\\(\\\);" 1 "gimple" } }
+ !$omp end parallel
+ end subroutine
end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-16.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-16.f90
index fc97322e667..5e34d474da4 100644
--- a/gcc/testsuite/gfortran.dg/gomp/declare-variant-16.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-16.f90
@@ -10,15 +10,27 @@ module main
subroutine base ()
!$omp declare variant (variant) match (construct={parallel})
end subroutine
+
+ subroutine base2 ()
+ !$omp declare variant (base2: variant2) match (construct={target})
+ end subroutine
end interface
-
contains
subroutine variant ()
end subroutine
+ subroutine variant2 ()
+ end subroutine
+
subroutine test ()
!$omp parallel
call base () ! { dg-final { scan-tree-dump-times "variant \\\(\\\);" 1 "gimple" } }
!$omp end parallel
end subroutine
+
+ subroutine test2 ()
+ !$omp target
+ call base2 () ! { dg-final { scan-tree-dump-times "variant2 \\\(\\\);" 1 "gimple" } }
+ !$omp end target
+ end subroutine
end module
On Mon, Oct 18, 2021 at 10:05:29PM +0100, Kwok Cheung Yeung wrote:
> On 14/10/2021 1:47 pm, Jakub Jelinek wrote:
> > What I still miss is tests for the (proc_name : variant_name) syntax
> > in places where proc_name : is optional, but is supplied and is valid, like
> > e.g. in interface, or in subroutine/function and where proc_name specifies
> > the name of the containing interface or subroutine/function.
> > I see that syntax tested in some places with dg-error on that line and
> > in spaces where it isn't optional (e.g. at module scope before contains).
> > But if you want, that can be added incrementally.
>
> Do you mean something like these tests?
Yeah, LGTM, thanks.
Jakub
@@ -2863,143 +2863,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
@@ -21665,7 +21665,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)
@@ -21695,7 +21695,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
@@ -7764,7 +7764,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;
@@ -45281,7 +45281,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,
@@ -1554,6 +1554,70 @@ 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;
+}
+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;
@@ -2023,6 +2087,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. */
@@ -3423,6 +3490,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,444 @@ 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->next = gfc_current_ns->omp_declare_variant;
+ gfc_current_ns->omp_declare_variant = odv;
+
+ odv->variant_proc_symtree = variant_proc_st;
+ odv->base_proc_symtree = base_proc_st;
+
+ 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);
@@ -3111,6 +3111,34 @@ gfc_create_function_decl (gfc_namespace * ns, bool global)
if (ns->omp_declare_simd)
gfc_trans_omp_declare_simd (ns);
+
+ /* Move any 'declare variant' declarations from parent namespace to the
+ current namespace if the base name matches. */
+ gfc_namespace *parent_ns = ns->parent;
+ while (parent_ns)
+ {
+ gfc_omp_declare_variant *prev = NULL, *next;
+ for (gfc_omp_declare_variant *odv = parent_ns->omp_declare_variant;
+ odv != NULL; odv = next)
+ {
+ if (odv->base_proc_symtree->n.sym == ns->proc_name)
+ {
+ if (prev == NULL)
+ parent_ns->omp_declare_variant = odv->next;
+ else
+ prev->next = odv->next;
+ odv->next = ns->omp_declare_variant;
+ ns->omp_declare_variant = odv;
+ }
+ else
+ prev = odv;
+
+ next = odv->next;
+ }
+ parent_ns = parent_ns->parent;
+ }
+ if (ns->omp_declare_variant)
+ gfc_trans_omp_declare_variant (ns);
}
/* Return the decl used to hold the function return value. If
@@ -7258,3 +7258,139 @@ gfc_trans_omp_declare_simd (gfc_namespace *ns)
DECL_ATTRIBUTES (fndecl) = c;
}
}
+
+void
+gfc_trans_omp_declare_variant (gfc_namespace *ns)
+{
+ gfc_omp_declare_variant *odv;
+
+ for (odv = ns->omp_declare_variant; odv; odv = odv->next)
+ {
+ tree set_selectors = NULL_TREE;
+ tree base_fn_decl = ns->proc_name->backend_decl;
+ 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)
+ {
+ 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.subroutine
+ && !variant_proc_sym->attr.function)
+ {
+ gfc_error ("variant %qs is not a function or subroutine",
+ variant_proc_name);
+ 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 have incompatible "
+ "types: %s",
+ variant_proc_name, ns->proc_name->name, 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))
+ {
+ DECL_ATTRIBUTES (base_fn_decl)
+ = tree_cons (
+ get_identifier ("omp declare variant base"),
+ build_tree_list (gfc_get_symbol_decl (variant_proc_sym),
+ 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 *);
@@ -11599,8 +11599,11 @@ omp_construct_selector_matches (enum tree_code *constructs, int nconstructs,
}
}
if (!target_seen
- && lookup_attribute ("omp declare target block",
- DECL_ATTRIBUTES (current_function_decl)))
+ && (lookup_attribute ("omp declare target block",
+ DECL_ATTRIBUTES (current_function_decl))
+ || (lang_GNU_Fortran ()
+ && lookup_attribute ("omp declare target",
+ DECL_ATTRIBUTES (current_function_decl)))))
{
if (scores)
codes.safe_push (OMP_TARGET);
@@ -1094,6 +1094,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. */
@@ -1105,7 +1245,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 *);
new file mode 100644
@@ -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
new file mode 100644
@@ -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
+
new file mode 100644
@@ -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
new file mode 100644
@@ -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
+
new file mode 100644
@@ -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
new file mode 100644
@@ -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
new file mode 100644
@@ -0,0 +1,23 @@
+! { 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 test2 ()
+ !$omp declare target
+ !$omp parallel
+ call base () ! { dg-final { scan-tree-dump-times "variant \\\(\\\);" 1 "gimple" } }
+ !$omp end parallel
+ end subroutine
+end module
new file mode 100644
@@ -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
new file mode 100644
@@ -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
new file mode 100644
@@ -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
new file mode 100644
@@ -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
new file mode 100644
@@ -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
new file mode 100644
@@ -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
new file mode 100644
@@ -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
new file mode 100644
@@ -0,0 +1,210 @@
+! { 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 ()
+ !$omp declare target
+ !$omp parallel
+ call f18 () ! { dg-final { scan-tree-dump-times "f17 \\\(\\\);" 1 "gimple" } }
+ !$omp end parallel
+ end subroutine
+
+ subroutine test3 ()
+ !$omp parallel
+ call f20 () ! { dg-final { scan-tree-dump-times "f20 \\\(\\\);" 1 "gimple" { xfail *-*-* } } }
+ !$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
new file mode 100644
@@ -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
new file mode 100644
@@ -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