From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1534) id 30F1D385C40B; Fri, 15 Oct 2021 08:49:14 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 30F1D385C40B Content-Type: text/plain; charset="us-ascii" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit From: Tobias Burnus To: gcc-cvs@gcc.gnu.org Subject: [gcc/devel/omp/gcc-11] openmp, fortran: Add support for OpenMP declare variant directive in Fortran X-Act-Checkin: gcc X-Git-Author: Kwok Cheung Yeung X-Git-Refname: refs/heads/devel/omp/gcc-11 X-Git-Oldrev: e0fa99e57af6cbcd1b6c32a8968df336f13e2029 X-Git-Newrev: b2c80707a4960fd6c45f0667dabcecda4762dff5 Message-Id: <20211015084914.30F1D385C40B@sourceware.org> Date: Fri, 15 Oct 2021 08:49:14 +0000 (GMT) X-BeenThere: gcc-cvs@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-cvs mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Fri, 15 Oct 2021 08:49:14 -0000 https://gcc.gnu.org/g:b2c80707a4960fd6c45f0667dabcecda4762dff5 commit b2c80707a4960fd6c45f0667dabcecda4762dff5 Author: Kwok Cheung Yeung Date: Fri Oct 15 10:02:39 2021 +0200 openmp, fortran: Add support for OpenMP declare variant directive in Fortran 2021-10-14 Kwok Cheung Yeung 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. (cherry picked from commit 724ee5a0093da443563ae98ec5cb76164c36be80) Diff: --- gcc/ChangeLog.omp | 11 + gcc/c-family/ChangeLog.omp | 10 + gcc/c-family/c-omp.c | 137 ------ gcc/c/ChangeLog.omp | 9 + gcc/c/c-parser.c | 4 +- gcc/cp/ChangeLog.omp | 10 + gcc/cp/decl.c | 2 +- gcc/cp/parser.c | 2 +- gcc/fortran/ChangeLog.omp | 42 ++ gcc/fortran/gfortran.h | 73 ++- gcc/fortran/match.h | 1 + gcc/fortran/openmp.c | 516 ++++++++++++++++++++- gcc/fortran/parse.c | 25 + gcc/fortran/symbol.c | 1 + gcc/fortran/trans-decl.c | 16 +- gcc/fortran/trans-openmp.c | 204 ++++++++ gcc/fortran/trans-stmt.h | 1 + gcc/omp-general.c | 143 +++++- gcc/omp-general.h | 3 + gcc/testsuite/ChangeLog.omp | 26 ++ .../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/ChangeLog.omp | 7 + .../libgomp.fortran/declare-variant-1.f90 | 33 ++ 42 files changed, 3019 insertions(+), 149 deletions(-) diff --git a/gcc/ChangeLog.omp b/gcc/ChangeLog.omp index b97c1acaf49..891ccaa1e1d 100644 --- a/gcc/ChangeLog.omp +++ b/gcc/ChangeLog.omp @@ -1,3 +1,14 @@ +2021-10-15 Tobias Burnus + + Backported from master: + 2021-10-14 Kwok Cheung Yeung + + * 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. + 2021-10-12 Julian Brown Revert: diff --git a/gcc/c-family/ChangeLog.omp b/gcc/c-family/ChangeLog.omp index 48ca80ae153..a436e372695 100644 --- a/gcc/c-family/ChangeLog.omp +++ b/gcc/c-family/ChangeLog.omp @@ -1,3 +1,13 @@ +2021-10-15 Tobias Burnus + + Backported from master: + 2021-10-14 Kwok Cheung Yeung + + * 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. + 2021-10-12 Tobias Burnus Backported from master: diff --git a/gcc/c-family/c-omp.c b/gcc/c-family/c-omp.c index e77aa462028..184eb6e8dac 100644 --- a/gcc/c-family/c-omp.c +++ b/gcc/c-family/c-omp.c @@ -3056,143 +3056,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 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 % " - "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/ChangeLog.omp b/gcc/c/ChangeLog.omp index 4fe0b909492..d24d18600f8 100644 --- a/gcc/c/ChangeLog.omp +++ b/gcc/c/ChangeLog.omp @@ -1,3 +1,12 @@ +2021-10-15 Tobias Burnus + + Backported from master: + 2021-10-14 Kwok Cheung Yeung + + * 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. + 2021-10-09 Tobias Burnus Backported from master: diff --git a/gcc/c/c-parser.c b/gcc/c/c-parser.c index 8123df2158e..86784035ea0 100644 --- a/gcc/c/c-parser.c +++ b/gcc/c/c-parser.c @@ -21731,7 +21731,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) @@ -21761,7 +21761,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/ChangeLog.omp b/gcc/cp/ChangeLog.omp index 0d506cc31fd..dbaa8fff6fc 100644 --- a/gcc/cp/ChangeLog.omp +++ b/gcc/cp/ChangeLog.omp @@ -1,3 +1,13 @@ +2021-10-15 Tobias Burnus + + Backported from master: + 2021-10-14 Kwok Cheung Yeung + + * 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. + 2021-10-09 Tobias Burnus Backported from master: diff --git a/gcc/cp/decl.c b/gcc/cp/decl.c index df70b5d24a6..5916200ceb0 100644 --- a/gcc/cp/decl.c +++ b/gcc/cp/decl.c @@ -7636,7 +7636,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 035fe018554..a474999e7b9 100644 --- a/gcc/cp/parser.c +++ b/gcc/cp/parser.c @@ -45055,7 +45055,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/ChangeLog.omp b/gcc/fortran/ChangeLog.omp index aae436ef6e5..241d19aaa2c 100644 --- a/gcc/fortran/ChangeLog.omp +++ b/gcc/fortran/ChangeLog.omp @@ -1,3 +1,45 @@ +2021-10-15 Tobias Burnus + + Backported from master: + 2021-10-14 Kwok Cheung Yeung + + * 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. + 2021-10-13 Tobias Burnus Backported from master: diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 856bf35b7cc..7046c257cc4 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -273,7 +273,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, @@ -1588,6 +1588,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; @@ -2057,6 +2124,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. */ @@ -3457,6 +3527,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 0cf9872bf7a..654d121d88e 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -169,6 +169,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 @@ -1367,7 +1431,8 @@ 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 openmp_target = false) + bool openacc = false, bool context_selector = false, + bool openmp_target = false) { bool error = false; gfc_omp_clauses *c = gfc_get_omp_clauses (); @@ -2857,7 +2922,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"); @@ -3513,7 +3580,7 @@ static match match_omp (gfc_exec_op op, const omp_mask mask) { gfc_omp_clauses *c; - if (gfc_match_omp_clauses (&c, mask, true, true, false, + if (gfc_match_omp_clauses (&c, mask, true, true, false, false, (op == EXEC_OMP_TARGET)) != MATCH_YES) return MATCH_ERROR; new_st.op = op; @@ -4431,6 +4498,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 9750addfff5..75d583f2583 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -27,6 +27,7 @@ along with GCC; see the file COPYING3. If not see #include #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 @@ -862,6 +863,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); @@ -1720,6 +1723,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 @@ -2363,6 +2367,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; @@ -6812,6 +6819,24 @@ done: | OMP_REQUIRES_UNIFIED_SHARED_MEMORY); } + /* 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 dba9816edbc..57d044d4923 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -2363,9 +2363,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; } @@ -3123,6 +3127,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 9fe7b5f4e15..6f0fadd50c3 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -7340,3 +7340,207 @@ gfc_trans_omp_declare_simd (gfc_namespace *ns) DECL_ATTRIBUTES (fndecl) = c; } } + +void +gfc_trans_omp_declare_variant (gfc_namespace *ns) +{ + tree base_fn_decl = ns->proc_name->backend_decl; + gfc_namespace *search_ns = ns; + gfc_omp_declare_variant *next; + + for (gfc_omp_declare_variant *odv = search_ns->omp_declare_variant; + search_ns; odv = next) + { + /* Look in the parent namespace if there are no more directives in the + current namespace. */ + if (!odv) + { + search_ns = search_ns->parent; + if (search_ns) + next = search_ns->omp_declare_variant; + continue; + } + + next = odv->next; + + if (odv->error_p) + continue; + + /* Check directive the first time it is encountered. */ + bool error_found = true; + + if (odv->checked_p) + error_found = false; + if (odv->base_proc_symtree == NULL) + { + if (!search_ns->proc_name->attr.function + && !search_ns->proc_name->attr.subroutine) + gfc_error ("The base name for 'declare variant' must be " + "specified at %L ", &odv->where); + else + error_found = false; + } + else + { + if (!search_ns->contained + && strcmp (odv->base_proc_symtree->name, + ns->proc_name->name)) + gfc_error ("The base name at %L does not match the name of the " + "current procedure", &odv->where); + else if (odv->base_proc_symtree->n.sym->attr.entry) + gfc_error ("The base name at %L must not be an entry name", + &odv->where); + else if (odv->base_proc_symtree->n.sym->attr.generic) + gfc_error ("The base name at %L must not be a generic name", + &odv->where); + else if (odv->base_proc_symtree->n.sym->attr.proc_pointer) + gfc_error ("The base name at %L must not be a procedure pointer", + &odv->where); + else if (odv->base_proc_symtree->n.sym->attr.implicit_type) + gfc_error ("The base procedure at %L must have an explicit " + "interface", &odv->where); + else + error_found = false; + } + + odv->checked_p = true; + if (error_found) + { + odv->error_p = true; + continue; + } + + /* Ignore directives that do not apply to the current procedure. */ + if ((odv->base_proc_symtree == NULL && search_ns != ns) + || (odv->base_proc_symtree != NULL + && strcmp (odv->base_proc_symtree->name, ns->proc_name->name))) + continue; + + tree set_selectors = NULL_TREE; + gfc_omp_set_selector *oss; + + for (oss = odv->set_selectors; oss; oss = oss->next) + { + tree selectors = NULL_TREE; + gfc_omp_selector *os; + for (os = oss->trait_selectors; os; os = os->next) + { + tree properties = NULL_TREE; + gfc_omp_trait_property *otp; + + for (otp = os->properties; otp; otp = otp->next) + { + switch (otp->property_kind) + { + case CTX_PROPERTY_USER: + case CTX_PROPERTY_EXPR: + { + gfc_se se; + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, otp->expr); + properties = tree_cons (NULL_TREE, se.expr, + properties); + } + break; + case CTX_PROPERTY_ID: + properties = tree_cons (get_identifier (otp->name), + NULL_TREE, properties); + break; + case CTX_PROPERTY_NAME_LIST: + { + tree prop = NULL_TREE, value = NULL_TREE; + if (otp->is_name) + prop = get_identifier (otp->name); + else + value = gfc_conv_constant_to_tree (otp->expr); + + properties = tree_cons (prop, value, properties); + } + break; + case CTX_PROPERTY_SIMD: + properties = gfc_trans_omp_clauses (NULL, otp->clauses, + odv->where, true); + break; + default: + gcc_unreachable (); + } + } + + if (os->score) + { + gfc_se se; + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, os->score); + properties = tree_cons (get_identifier (" score"), + se.expr, properties); + } + + selectors = tree_cons (get_identifier (os->trait_selector_name), + properties, selectors); + } + + set_selectors + = tree_cons (get_identifier (oss->trait_set_selector_name), + selectors, set_selectors); + } + + const char *variant_proc_name = odv->variant_proc_symtree->name; + gfc_symbol *variant_proc_sym = odv->variant_proc_symtree->n.sym; + if (variant_proc_sym == NULL || variant_proc_sym->attr.implicit_type) + { + gfc_symtree *proc_st; + gfc_find_sym_tree (variant_proc_name, gfc_current_ns, 1, &proc_st); + variant_proc_sym = proc_st->n.sym; + } + if (variant_proc_sym == NULL) + { + gfc_error ("Cannot find symbol %qs", variant_proc_name); + continue; + } + set_selectors = omp_check_context_selector + (gfc_get_location (&odv->where), set_selectors); + if (set_selectors != error_mark_node) + { + if (!variant_proc_sym->attr.implicit_type + && !variant_proc_sym->attr.subroutine + && !variant_proc_sym->attr.function) + { + gfc_error ("variant %qs at %L is not a function or subroutine", + variant_proc_name, &odv->where); + variant_proc_sym = NULL; + } + else if (omp_get_context_selector (set_selectors, "construct", + "simd") == NULL_TREE) + { + char err[256]; + if (!gfc_compare_interfaces (ns->proc_name, variant_proc_sym, + variant_proc_sym->name, 0, 1, + err, sizeof (err), NULL, NULL)) + { + gfc_error ("variant %qs and base %qs at %L have " + "incompatible types: %s", + variant_proc_name, ns->proc_name->name, + &odv->where, err); + variant_proc_sym = NULL; + } + } + if (variant_proc_sym != NULL) + { + gfc_set_sym_referenced (variant_proc_sym); + tree construct = omp_get_context_selector (set_selectors, + "construct", NULL); + omp_mark_declare_variant (gfc_get_location (&odv->where), + gfc_get_symbol_decl (variant_proc_sym), + construct); + if (omp_context_selector_matches (set_selectors)) + { + tree id = get_identifier ("omp declare variant base"); + tree variant = gfc_get_symbol_decl (variant_proc_sym); + DECL_ATTRIBUTES (base_fn_decl) + = tree_cons (id, build_tree_list (variant, set_selectors), + DECL_ATTRIBUTES (base_fn_decl)); + } + } + } + } +} diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h index 763f8940404..1a24d9b4cdc 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -71,6 +71,7 @@ tree gfc_trans_deallocate_array (tree); /* trans-openmp.c */ tree gfc_trans_omp_directive (gfc_code *); void gfc_trans_omp_declare_simd (gfc_namespace *); +void gfc_trans_omp_declare_variant (gfc_namespace *); tree gfc_trans_oacc_directive (gfc_code *); tree gfc_trans_oacc_declare (gfc_namespace *); diff --git a/gcc/omp-general.c b/gcc/omp-general.c index 127e6879258..5b34584ad05 100644 --- a/gcc/omp-general.c +++ b/gcc/omp-general.c @@ -1110,6 +1110,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 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 % " + "selector sets", variant); +} + + /* Return a name from PROP, a property in selectors accepting name lists. */ @@ -1121,7 +1261,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 e9d6a42c068..95693152227 100644 --- a/gcc/omp-general.h +++ b/gcc/omp-general.h @@ -105,6 +105,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/ChangeLog.omp b/gcc/testsuite/ChangeLog.omp index 019085cd6c3..e716eef151d 100644 --- a/gcc/testsuite/ChangeLog.omp +++ b/gcc/testsuite/ChangeLog.omp @@ -1,3 +1,29 @@ +2021-10-15 Tobias Burnus + + Backported from master: + 2021-10-14 Kwok Cheung Yeung + + * 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. + 2021-10-13 Tobias Burnus Backported from master: 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/ChangeLog.omp b/libgomp/ChangeLog.omp index 9350f7c786a..73afad08e17 100644 --- a/libgomp/ChangeLog.omp +++ b/libgomp/ChangeLog.omp @@ -1,3 +1,10 @@ +2021-10-15 Tobias Burnus + + Backported from master: + 2021-10-14 Kwok Cheung Yeung + + * testsuite/libgomp.fortran/declare-variant-1.f90: New test. + 2021-10-13 Tobias Burnus Backported from master: 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