From patchwork Wed Oct 6 11:39:01 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Kwok Cheung Yeung X-Patchwork-Id: 45922 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 852B53854824 for ; Wed, 6 Oct 2021 11:39:47 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from esa1.mentor.iphmx.com (esa1.mentor.iphmx.com [68.232.129.153]) by sourceware.org (Postfix) with ESMTPS id 2F31F3858018; Wed, 6 Oct 2021 11:39:15 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 2F31F3858018 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com IronPort-SDR: q7Zs3hu1+7eaPMEd6io6ZImYQNFOwG0FVBhSy8XbE5+TY19qnT9unXX0WqvuER/Z3kva3YYW+x 9HnSGj5SeGUBwyzSU6UB6jnf6vYvT/MKPkn+jIVIVorxwwBpF/EB9hcjQUV+kE7kYdDcW5C+yH 6geASnqfKx13R+OY1rD1efUSDA8xvBsxCUPogVPz/mbd9GQlbnCoXxudrZjYQAnKHQkUmcqtDh 6+Vbgo7+df4jDNtyyjGTP7W9dQnqKi9frIfGiUBwAl2zjnIkLznI8S641S17VN0r/Nl+XDXnTx /Sss0Un1PJl+UrLERSMmDF0M X-IronPort-AV: E=Sophos;i="5.85,350,1624348800"; d="scan'208";a="69278974" Received: from orw-gwy-01-in.mentorg.com ([192.94.38.165]) by esa1.mentor.iphmx.com with ESMTP; 06 Oct 2021 03:39:14 -0800 IronPort-SDR: h+pKfg4d3M5VS7+saI0RxxcknjJzdkqPNLYWAE9BdMXUP0Msmj6t7Lscxd1E273TseGOQEBFos D8OHo5qugJYsby88qNCp9QnVN9ZJqCq3FM8yuRPgaIL1sFFDxrG3deMWtEDqo2AkCxNLG8yH/l Qruj4pUwebCmfu7gcpUD1I30bBM6s/gVXIiyJj4TY9iCoPAynWZ9kYn1Tmnu/1JK4Kybvq8Mmv eMxs5DSMAH/BCGLsU8j2j2rP41ySOFxvsuAeGtcZzV1V1fejGI/bxzRyJpb4pcMYIdqLF+RFaj 7W4= Message-ID: <8296c73e-2a16-0232-d1ac-49c5c7330481@codesourcery.com> Date: Wed, 6 Oct 2021 12:39:01 +0100 MIME-Version: 1.0 User-Agent: Mozilla/5.0 (Windows NT 10.0; Win64; x64; rv:91.0) Gecko/20100101 Thunderbird/91.1.2 From: Kwok Cheung Yeung Subject: [PATCH] openmp, fortran: Add support for declare variant in Fortran To: gcc-patches , fortran , Jakub Jelinek , Tobias Burnus X-Originating-IP: [137.202.0.90] X-ClientProxiedBy: svr-ies-mbx-02.mgc.mentorg.com (139.181.222.2) To SVR-IES-MBX-04.mgc.mentorg.com (139.181.222.4) X-Spam-Status: No, score=-12.0 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, SPF_HELO_PASS, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" Hello This patch adds support for the OpenMP 'declare variant' directive in Fortran (C/C++ support is already present). For most part, this is a straightforward port of the C frontend code. I have ported all the c-c++-common/gomp/declare-variant-*.c tests to Fortran in gfortran.dg/gomp/, skipping over any tests involving inline assembly. I have also ported libgomp.c/target-42.c to Fortran as libgomp.fortran/declare-variant-1.f90. I have moved the c_omp_check_context_selector and c_omp_mark_declare_variant functions from c-family/c-omp.c into omp-general.c and removed the 'c_' prefix, as these functions can be reused for Fortran. Since the Fortran FE parses code first before translating it into tree form, fatal parser errors in a source file will result in errors in the same source file that are detected at translation time not being displayed (as compilation does not reach that stage). I have therefore separated out the translation errors in declare-variant-2.f90 into declare-variant-2a.f90. In secion 2.3.1 of the OpenMP 5.0 spec, it says: 3. For functions within a declare target block, the target trait is added to the beginning of the set... But OpenMP in Fortran doesn't have the notion of a declare target _block_ (i.e. the #pragma omp declare target/#pragma omp end declare target form), only the !$omp declare target (extended-list)/[clause] form (which C/C++ also has). The C FE differentiates between the two (it applies an 'omp declare target block' attribute for the first, an 'omp declare target' for the second) but only the first matches against the 'target' construct in a context selector. I opted to match against 'omp declare target' for Fortran only, otherwise this functionality won't get exercised in Fortran at all. This difference is tested in test3 of declare-variant-8.f90, which I have XFAILed for now. The Fortran 'declare variant' directive can also optionally take the name of the base procedure - this is implemented by moving any 'declare variant' directives with a matching base name in the parent namespaces of a function into the function namespace itself, such that at translation time it appears as if the directive was placed in the base procedure. This is tested in declare-variant-15.f90. Bootstrapped on x86_64, and the gfortran testsuite and libgomp.fortran tests run with no regressions. Okay for trunk? Thanks Kwok Yeung commit 317d69154cc91d2f6e7fed6c054dc2b3852bf604 Author: Kwok Cheung Yeung Date: Wed Oct 6 04:16:55 2021 -0700 openmp, fortran: Add support for OpenMP declare variant directive in Fortran 2021-10-05 Kwok Cheung Yeung gcc/c-family/ * c-omp.c (c_omp_check_context_selector): Rename to omp_check_context_selector and move to omp-general.c. (c_omp_mark_declare_variant): Rename to omp_mark_declare_variant and move to omp-general.c. gcc/c/ * c-parser.c (c_finish_omp_declare_variant): Change call from c_omp_check_context_selector to omp_check_context_selector. Change call from c_omp_mark_declare_variant to omp_mark_declare_variant. gcc/cp/ * decl.c (omp_declare_variant_finalize_one): Change call from c_omp_mark_declare_variant to omp_mark_declare_variant. * parser.c (cp_finish_omp_declare_variant): Change call from c_omp_check_context_selector to omp_check_context_selector. gcc/fortran/ * gfortran.h (enum gfc_statement): Add ST_OMP_DECLARE_VARIANT. (enum gfc_omp_trait_property_kind): New. (struct gfc_omp_trait_property): New. (gfc_get_omp_trait_property): New macro. (struct gfc_omp_selector): New. (gfc_get_omp_selector): New macro. (struct gfc_omp_set_selector): New. (gfc_get_omp_set_selector): New macro. (struct gfc_omp_declare_variant): New. (gfc_get_omp_declare_variant): New macro. (struct gfc_namespace): Add omp_declare_variant field. (gfc_free_omp_declare_variant_list): New prototype. * match.h (gfc_match_omp_declare_variant): New prototype. * openmp.c (gfc_free_omp_trait_property_list): New. (gfc_free_omp_selector_list): New. (gfc_free_omp_set_selector_list): New. (gfc_free_omp_declare_variant_list): New. (gfc_match_omp_clauses): Add extra optional argument. Handle end of clauses for context selectors. (omp_construct_selectors, omp_device_selectors, omp_implementation_selectors, omp_user_selectors): New. (gfc_match_omp_context_selector): New. (gfc_match_omp_context_selector_specification): New. (gfc_match_omp_declare_variant): New. * parse.c: Include tree-core.h and omp-general.h. (decode_omp_directive): Handle 'declare variant'. (case_omp_decl): Include ST_OMP_DECLARE_VARIANT. (gfc_ascii_statement): Handle ST_OMP_DECLARE_VARIANT. (gfc_parse_file): Initialize omp_requires_mask. * symbol.c (gfc_free_namespace): Call gfc_free_omp_declare_variant_list. * trans-decl.c (gfc_create_function_decl): Move relevant 'declare variant' declarations into base function namespace. Call gfc_trans_omp_declare_variant. * trans-openmp.c (gfc_trans_omp_declare_variant): New. * trans-stmt.h (gfc_trans_omp_declare_variant): New prototype. gcc/ * gimplify.c (omp_construct_selector_matches): Match target construct against 'omp declare target' attribute for Fortran. * omp-general.c (omp_check_context_selector): Move from c-omp.c. (omp_mark_declare_variant): Move from c-omp.c. (omp_context_name_list_prop): Update for Fortran strings. * omp-general.h (omp_check_context_selector): New prototype. (omp_mark_declare_variant): New prototype. gcc/testsuite/ * gfortran.dg/gomp/declare-variant-1.f90: New test. * gfortran.dg/gomp/declare-variant-10.f90: New test. * gfortran.dg/gomp/declare-variant-11.f90: New test. * gfortran.dg/gomp/declare-variant-12.f90: New test. * gfortran.dg/gomp/declare-variant-13.f90: New test. * gfortran.dg/gomp/declare-variant-14.f90: New test. * gfortran.dg/gomp/declare-variant-15.f90: New test. * gfortran.dg/gomp/declare-variant-2.f90: New test. * gfortran.dg/gomp/declare-variant-2a.f90: New test. * gfortran.dg/gomp/declare-variant-3.f90: New test. * gfortran.dg/gomp/declare-variant-4.f90: New test. * gfortran.dg/gomp/declare-variant-5.f90: New test. * gfortran.dg/gomp/declare-variant-6.f90: New test. * gfortran.dg/gomp/declare-variant-7.f90: New test. * gfortran.dg/gomp/declare-variant-8.f90: New test. * gfortran.dg/gomp/declare-variant-9.f90: New test. libgomp/ * testsuite/libgomp.fortran/declare-variant-1.f90: New test. diff --git a/gcc/c-family/c-omp.c b/gcc/c-family/c-omp.c index 2849fdabc3d..c7140fdacfd 100644 --- a/gcc/c-family/c-omp.c +++ b/gcc/c-family/c-omp.c @@ -2863,143 +2863,6 @@ c_omp_predetermined_mapping (tree decl) } -/* Diagnose errors in an OpenMP context selector, return CTX if - it is correct or error_mark_node otherwise. */ - -tree -c_omp_check_context_selector (location_t loc, tree ctx) -{ - /* Each trait-set-selector-name can only be specified once. - There are just 4 set names. */ - for (tree t1 = ctx; t1; t1 = TREE_CHAIN (t1)) - for (tree t2 = TREE_CHAIN (t1); t2; t2 = TREE_CHAIN (t2)) - if (TREE_PURPOSE (t1) == TREE_PURPOSE (t2)) - { - error_at (loc, "selector set %qs specified more than once", - IDENTIFIER_POINTER (TREE_PURPOSE (t1))); - return error_mark_node; - } - for (tree t = ctx; t; t = TREE_CHAIN (t)) - { - /* Each trait-selector-name can only be specified once. */ - if (list_length (TREE_VALUE (t)) < 5) - { - for (tree t1 = TREE_VALUE (t); t1; t1 = TREE_CHAIN (t1)) - for (tree t2 = TREE_CHAIN (t1); t2; t2 = TREE_CHAIN (t2)) - if (TREE_PURPOSE (t1) == TREE_PURPOSE (t2)) - { - error_at (loc, - "selector %qs specified more than once in set %qs", - IDENTIFIER_POINTER (TREE_PURPOSE (t1)), - IDENTIFIER_POINTER (TREE_PURPOSE (t))); - return error_mark_node; - } - } - else - { - hash_set 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/c-parser.c b/gcc/c/c-parser.c index a66f43f6dc2..9161cbb6fe0 100644 --- a/gcc/c/c-parser.c +++ b/gcc/c/c-parser.c @@ -21665,7 +21665,7 @@ c_finish_omp_declare_variant (c_parser *parser, tree fndecl, tree parms) tree ctx = c_parser_omp_context_selector_specification (parser, parms); if (ctx == error_mark_node) goto fail; - ctx = c_omp_check_context_selector (match_loc, ctx); + ctx = omp_check_context_selector (match_loc, ctx); if (ctx != error_mark_node && variant != error_mark_node) { if (TREE_CODE (variant) != FUNCTION_DECL) @@ -21695,7 +21695,7 @@ c_finish_omp_declare_variant (c_parser *parser, tree fndecl, tree parms) { C_DECL_USED (variant) = 1; tree construct = omp_get_context_selector (ctx, "construct", NULL); - c_omp_mark_declare_variant (match_loc, variant, construct); + omp_mark_declare_variant (match_loc, variant, construct); if (omp_context_selector_matches (ctx)) { tree attr diff --git a/gcc/cp/decl.c b/gcc/cp/decl.c index 722e540baba..7c1b6b62bab 100644 --- a/gcc/cp/decl.c +++ b/gcc/cp/decl.c @@ -7764,7 +7764,7 @@ omp_declare_variant_finalize_one (tree decl, tree attr) else { tree construct = omp_get_context_selector (ctx, "construct", NULL); - c_omp_mark_declare_variant (match_loc, variant, construct); + omp_mark_declare_variant (match_loc, variant, construct); if (!omp_context_selector_matches (ctx)) return true; TREE_PURPOSE (TREE_VALUE (attr)) = variant; diff --git a/gcc/cp/parser.c b/gcc/cp/parser.c index c6f1a9796c5..f605014d110 100644 --- a/gcc/cp/parser.c +++ b/gcc/cp/parser.c @@ -45281,7 +45281,7 @@ cp_finish_omp_declare_variant (cp_parser *parser, cp_token *pragma_tok, tree ctx = cp_parser_omp_context_selector_specification (parser, true); if (ctx == error_mark_node) goto fail; - ctx = c_omp_check_context_selector (match_loc, ctx); + ctx = omp_check_context_selector (match_loc, ctx); if (ctx != error_mark_node && variant != error_mark_node) { tree match_loc_node = maybe_wrap_with_location (integer_zero_node, diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index c25d1cca3a8..d3dcae07e19 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -239,7 +239,7 @@ enum gfc_statement ST_OMP_DO_SIMD, ST_OMP_END_DO_SIMD, ST_OMP_PARALLEL_DO_SIMD, ST_OMP_END_PARALLEL_DO_SIMD, ST_OMP_DECLARE_SIMD, ST_OMP_DECLARE_REDUCTION, ST_OMP_TARGET, ST_OMP_END_TARGET, ST_OMP_TARGET_DATA, ST_OMP_END_TARGET_DATA, - ST_OMP_TARGET_UPDATE, ST_OMP_DECLARE_TARGET, + ST_OMP_TARGET_UPDATE, ST_OMP_DECLARE_TARGET, ST_OMP_DECLARE_VARIANT, ST_OMP_TEAMS, ST_OMP_END_TEAMS, ST_OMP_DISTRIBUTE, ST_OMP_END_DISTRIBUTE, ST_OMP_DISTRIBUTE_SIMD, ST_OMP_END_DISTRIBUTE_SIMD, ST_OMP_DISTRIBUTE_PARALLEL_DO, ST_OMP_END_DISTRIBUTE_PARALLEL_DO, @@ -1554,6 +1554,70 @@ typedef struct gfc_omp_declare_simd gfc_omp_declare_simd; #define gfc_get_omp_declare_simd() XCNEW (gfc_omp_declare_simd) + +enum gfc_omp_trait_property_kind +{ + CTX_PROPERTY_NONE, + CTX_PROPERTY_USER, + CTX_PROPERTY_NAME_LIST, + CTX_PROPERTY_ID, + CTX_PROPERTY_EXPR, + CTX_PROPERTY_SIMD +}; + +typedef struct gfc_omp_trait_property +{ + struct gfc_omp_trait_property *next; + enum gfc_omp_trait_property_kind property_kind; + bool is_name : 1; + + union + { + gfc_expr *expr; + gfc_symbol *sym; + gfc_omp_clauses *clauses; + char *name; + }; +} gfc_omp_trait_property; +#define gfc_get_omp_trait_property() XCNEW (gfc_omp_trait_property) + +typedef struct gfc_omp_selector +{ + struct gfc_omp_selector *next; + + char *trait_selector_name; + gfc_expr *score; + struct gfc_omp_trait_property *properties; +} gfc_omp_selector; +#define gfc_get_omp_selector() XCNEW (gfc_omp_selector) + +typedef struct gfc_omp_set_selector +{ + struct gfc_omp_set_selector *next; + + const char *trait_set_selector_name; + struct gfc_omp_selector *trait_selectors; +} gfc_omp_set_selector; +#define gfc_get_omp_set_selector() XCNEW (gfc_omp_set_selector) + + +/* Node in the linked list used for storing !$omp declare variant + constructs. */ + +typedef struct gfc_omp_declare_variant +{ + struct gfc_omp_declare_variant *next; + locus where; /* Where the !$omp declare variant construct occurred. */ + + struct gfc_symtree *base_proc_symtree; + struct gfc_symtree *variant_proc_symtree; + + gfc_omp_set_selector *set_selectors; +} +gfc_omp_declare_variant; +#define gfc_get_omp_declare_variant() XCNEW (gfc_omp_declare_variant) + + typedef struct gfc_omp_udr { struct gfc_omp_udr *next; @@ -2023,6 +2087,9 @@ typedef struct gfc_namespace /* Linked list of !$omp declare simd constructs. */ struct gfc_omp_declare_simd *omp_declare_simd; + /* Linked list of !$omp declare variant constructs. */ + struct gfc_omp_declare_variant *omp_declare_variant; + /* A hash set for the the gfc expressions that have already been finalized in this namespace. */ @@ -3423,6 +3490,7 @@ bool gfc_omp_requires_add_clause (gfc_omp_requires_kind, const char *, void gfc_check_omp_requires (gfc_namespace *, int); void gfc_free_omp_clauses (gfc_omp_clauses *); void gfc_free_oacc_declare_clauses (struct gfc_oacc_declare *); +void gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list); void gfc_free_omp_declare_simd (gfc_omp_declare_simd *); void gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *); void gfc_free_omp_udr (gfc_omp_udr *); diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 92fd127a57f..21e94f79d95 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -160,6 +160,7 @@ match gfc_match_omp_critical (void); match gfc_match_omp_declare_reduction (void); match gfc_match_omp_declare_simd (void); match gfc_match_omp_declare_target (void); +match gfc_match_omp_declare_variant (void); match gfc_match_omp_depobj (void); match gfc_match_omp_distribute (void); match gfc_match_omp_distribute_parallel_do (void); diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index 6a4ca2868f8..115e43eb1b3 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -168,6 +168,70 @@ gfc_free_omp_declare_simd_list (gfc_omp_declare_simd *list) } } +static void +gfc_free_omp_trait_property_list (gfc_omp_trait_property *list) +{ + while (list) + { + gfc_omp_trait_property *current = list; + list = list->next; + switch (current->property_kind) + { + case CTX_PROPERTY_ID: + free (current->name); + break; + case CTX_PROPERTY_NAME_LIST: + if (current->is_name) + free (current->name); + break; + case CTX_PROPERTY_SIMD: + gfc_free_omp_clauses (current->clauses); + break; + default: + break; + } + free (current); + } +} + +static void +gfc_free_omp_selector_list (gfc_omp_selector *list) +{ + while (list) + { + gfc_omp_selector *current = list; + list = list->next; + gfc_free_omp_trait_property_list (current->properties); + free (current); + } +} + +static void +gfc_free_omp_set_selector_list (gfc_omp_set_selector *list) +{ + while (list) + { + gfc_omp_set_selector *current = list; + list = list->next; + gfc_free_omp_selector_list (current->trait_selectors); + free (current); + } +} + +/* Free an !$omp declare variant construct list. */ + +void +gfc_free_omp_declare_variant_list (gfc_omp_declare_variant *list) +{ + while (list) + { + gfc_omp_declare_variant *current = list; + list = list->next; + gfc_free_omp_set_selector_list (current->set_selectors); + free (current); + } +} + /* Free an !$omp declare reduction. */ void @@ -1353,7 +1417,7 @@ gfc_match_dupl_atomic (bool not_dupl, const char *name) static match gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, bool first = true, bool needs_space = true, - bool openacc = false) + bool openacc = false, bool context_selector = false) { bool error = false; gfc_omp_clauses *c = gfc_get_omp_clauses (); @@ -2843,7 +2907,9 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, } end: - if (error || gfc_match_omp_eos () != MATCH_YES) + if (error + || (context_selector && gfc_peek_ascii_char () != ')') + || (!context_selector && gfc_match_omp_eos () != MATCH_YES)) { if (!gfc_error_flag_test ()) gfc_error ("Failed to match clause at %C"); @@ -4429,6 +4495,444 @@ cleanup: } +static const char *const omp_construct_selectors[] = { + "simd", "target", "teams", "parallel", "do", NULL }; +static const char *const omp_device_selectors[] = { + "kind", "isa", "arch", NULL }; +static const char *const omp_implementation_selectors[] = { + "vendor", "extension", "atomic_default_mem_order", "unified_address", + "unified_shared_memory", "dynamic_allocators", "reverse_offload", NULL }; +static const char *const omp_user_selectors[] = { + "condition", NULL }; + + +/* OpenMP 5.0: + + trait-selector: + trait-selector-name[([trait-score:]trait-property[,trait-property[,...]])] + + trait-score: + score(score-expression) */ + +match +gfc_match_omp_context_selector (gfc_omp_set_selector *oss) +{ + do + { + char selector[GFC_MAX_SYMBOL_LEN + 1]; + + if (gfc_match_name (selector) != MATCH_YES) + { + gfc_error ("expected trait selector name at %C"); + return MATCH_ERROR; + } + + gfc_omp_selector *os = gfc_get_omp_selector (); + os->trait_selector_name = XNEWVEC (char, strlen (selector) + 1); + strcpy (os->trait_selector_name, selector); + os->next = oss->trait_selectors; + oss->trait_selectors = os; + + const char *const *selectors = NULL; + bool allow_score = true; + bool allow_user = false; + int property_limit = 0; + enum gfc_omp_trait_property_kind property_kind = CTX_PROPERTY_NONE; + switch (oss->trait_set_selector_name[0]) + { + case 'c': /* construct */ + selectors = omp_construct_selectors; + allow_score = false; + property_limit = 1; + property_kind = CTX_PROPERTY_SIMD; + break; + case 'd': /* device */ + selectors = omp_device_selectors; + allow_score = false; + allow_user = true; + property_limit = 3; + property_kind = CTX_PROPERTY_NAME_LIST; + break; + case 'i': /* implementation */ + selectors = omp_implementation_selectors; + allow_user = true; + property_limit = 3; + property_kind = CTX_PROPERTY_NAME_LIST; + break; + case 'u': /* user */ + selectors = omp_user_selectors; + property_limit = 1; + property_kind = CTX_PROPERTY_EXPR; + break; + default: + gcc_unreachable (); + } + for (int i = 0; ; i++) + { + if (selectors[i] == NULL) + { + if (allow_user) + { + property_kind = CTX_PROPERTY_USER; + break; + } + else + { + gfc_error ("selector '%s' not allowed for context selector " + "set '%s' at %C", + selector, oss->trait_set_selector_name); + return MATCH_ERROR; + } + } + if (i == property_limit) + property_kind = CTX_PROPERTY_NONE; + if (strcmp (selectors[i], selector) == 0) + break; + } + if (property_kind == CTX_PROPERTY_NAME_LIST + && oss->trait_set_selector_name[0] == 'i' + && strcmp (selector, "atomic_default_mem_order") == 0) + property_kind = CTX_PROPERTY_ID; + + if (gfc_match (" (") == MATCH_YES) + { + if (property_kind == CTX_PROPERTY_NONE) + { + gfc_error ("selector '%s' does not accept any properties at %C", + selector); + return MATCH_ERROR; + } + + if (allow_score && gfc_match (" score") == MATCH_YES) + { + if (gfc_match (" (") != MATCH_YES) + { + gfc_error ("expected '(' at %C"); + return MATCH_ERROR; + } + if (gfc_match_expr (&os->score) != MATCH_YES + || !gfc_resolve_expr (os->score) + || os->score->ts.type != BT_INTEGER + || os->score->rank != 0) + { + gfc_error ("score argument must be constant integer " + "expression at %C"); + return MATCH_ERROR; + } + + if (os->score->expr_type == EXPR_CONSTANT + && mpz_sgn (os->score->value.integer) < 0) + { + gfc_error ("score argument must be non-negative at %C"); + return MATCH_ERROR; + } + + if (gfc_match (" )") != MATCH_YES) + { + gfc_error ("expected ')' at %C"); + return MATCH_ERROR; + } + + if (gfc_match (" :") != MATCH_YES) + { + gfc_error ("expected : at %C"); + return MATCH_ERROR; + } + } + + gfc_omp_trait_property *otp = gfc_get_omp_trait_property (); + otp->property_kind = property_kind; + otp->next = os->properties; + os->properties = otp; + + switch (property_kind) + { + case CTX_PROPERTY_USER: + do + { + if (gfc_match_expr (&otp->expr) != MATCH_YES) + { + gfc_error ("property must be constant integer " + "expression or string literal at %C"); + return MATCH_ERROR; + } + + if (gfc_match (" ,") != MATCH_YES) + break; + } + while (1); + break; + case CTX_PROPERTY_ID: + { + char buf[GFC_MAX_SYMBOL_LEN + 1]; + if (gfc_match_name (buf) == MATCH_YES) + { + otp->name = XNEWVEC (char, strlen (buf) + 1); + strcpy (otp->name, buf); + } + else + { + gfc_error ("expected identifier at %C"); + return MATCH_ERROR; + } + } + break; + case CTX_PROPERTY_NAME_LIST: + do + { + char buf[GFC_MAX_SYMBOL_LEN + 1]; + if (gfc_match_name (buf) == MATCH_YES) + { + otp->name = XNEWVEC (char, strlen (buf) + 1); + strcpy (otp->name, buf); + otp->is_name = true; + } + else if (gfc_match_literal_constant (&otp->expr, 0) + != MATCH_YES + || otp->expr->ts.type != BT_CHARACTER) + { + gfc_error ("expected identifier or string literal " + "at %C"); + return MATCH_ERROR; + } + + if (gfc_match (" ,") == MATCH_YES) + { + otp = gfc_get_omp_trait_property (); + otp->property_kind = property_kind; + otp->next = os->properties; + os->properties = otp; + } + else + break; + } + while (1); + break; + case CTX_PROPERTY_EXPR: + if (gfc_match_expr (&otp->expr) != MATCH_YES) + { + gfc_error ("expected expression at %C"); + return MATCH_ERROR; + } + if (!gfc_resolve_expr (otp->expr) + || (otp->expr->ts.type != BT_LOGICAL + && otp->expr->ts.type != BT_INTEGER) + || otp->expr->rank != 0) + { + gfc_error ("property must be constant integer or logical " + "expression at %C"); + return MATCH_ERROR; + } + break; + case CTX_PROPERTY_SIMD: + { + if (gfc_match_omp_clauses (&otp->clauses, + OMP_DECLARE_SIMD_CLAUSES, + true, false, false, true) + != MATCH_YES) + { + gfc_error ("expected simd clause at %C"); + return MATCH_ERROR; + } + break; + } + default: + gcc_unreachable (); + } + + if (gfc_match (" )") != MATCH_YES) + { + gfc_error ("expected ')' at %C"); + return MATCH_ERROR; + } + } + else if (property_kind == CTX_PROPERTY_NAME_LIST + || property_kind == CTX_PROPERTY_ID + || property_kind == CTX_PROPERTY_EXPR) + { + if (gfc_match (" (") != MATCH_YES) + { + gfc_error ("expected '(' at %C"); + return MATCH_ERROR; + } + } + + if (gfc_match (" ,") != MATCH_YES) + break; + } + while (1); + + return MATCH_YES; +} + +/* OpenMP 5.0: + + trait-set-selector[,trait-set-selector[,...]] + + trait-set-selector: + trait-set-selector-name = { trait-selector[, trait-selector[, ...]] } + + trait-set-selector-name: + constructor + device + implementation + user */ + +match +gfc_match_omp_context_selector_specification (gfc_omp_declare_variant *odv) +{ + do + { + match m; + const char *selector_sets[] = { "construct", "device", + "implementation", "user" }; + const int selector_set_count + = sizeof (selector_sets) / sizeof (*selector_sets); + int i; + char buf[GFC_MAX_SYMBOL_LEN + 1]; + + m = gfc_match_name (buf); + if (m == MATCH_YES) + for (i = 0; i < selector_set_count; i++) + if (strcmp (buf, selector_sets[i]) == 0) + break; + + if (m != MATCH_YES || i == selector_set_count) + { + gfc_error ("expected 'construct', 'device', 'implementation' or " + "'user' at %C"); + return MATCH_ERROR; + } + + m = gfc_match (" ="); + if (m != MATCH_YES) + { + gfc_error ("expected '=' at %C"); + return MATCH_ERROR; + } + + m = gfc_match (" {"); + if (m != MATCH_YES) + { + gfc_error ("expected '{' at %C"); + return MATCH_ERROR; + } + + gfc_omp_set_selector *oss = gfc_get_omp_set_selector (); + oss->next = odv->set_selectors; + oss->trait_set_selector_name = selector_sets[i]; + odv->set_selectors = oss; + + if (gfc_match_omp_context_selector (oss) != MATCH_YES) + return MATCH_ERROR; + + m = gfc_match (" }"); + if (m != MATCH_YES) + { + gfc_error ("expected '}' at %C"); + return MATCH_ERROR; + } + + m = gfc_match (" ,"); + if (m != MATCH_YES) + break; + } + while (1); + + return MATCH_YES; +} + + +match +gfc_match_omp_declare_variant (void) +{ + bool first_p = true; + char buf[GFC_MAX_SYMBOL_LEN + 1]; + + if (gfc_match (" (") != MATCH_YES) + { + gfc_error ("expected '(' at %C"); + return MATCH_ERROR; + } + + gfc_symtree *base_proc_st, *variant_proc_st; + if (gfc_match_name (buf) != MATCH_YES) + { + gfc_error ("expected name at %C"); + return MATCH_ERROR; + } + + if (gfc_get_ha_sym_tree (buf, &base_proc_st)) + return MATCH_ERROR; + + if (gfc_match (" :") == MATCH_YES) + { + if (gfc_match_name (buf) != MATCH_YES) + { + gfc_error ("expected variant name at %C"); + return MATCH_ERROR; + } + + if (gfc_get_ha_sym_tree (buf, &variant_proc_st)) + return MATCH_ERROR; + } + else + { + /* Base procedure not specified. */ + variant_proc_st = base_proc_st; + base_proc_st = NULL; + } + + gfc_omp_declare_variant *odv; + odv = gfc_get_omp_declare_variant (); + odv->where = gfc_current_locus; + odv->next = gfc_current_ns->omp_declare_variant; + gfc_current_ns->omp_declare_variant = odv; + + odv->variant_proc_symtree = variant_proc_st; + odv->base_proc_symtree = base_proc_st; + + if (gfc_match (" )") != MATCH_YES) + { + gfc_error ("expected ')' at %C"); + return MATCH_ERROR; + } + + for (;;) + { + if (gfc_match (" match") != MATCH_YES) + { + if (first_p) + { + gfc_error ("expected 'match' at %C"); + return MATCH_ERROR; + } + else + break; + } + + if (gfc_match (" (") != MATCH_YES) + { + gfc_error ("expected '(' at %C"); + return MATCH_ERROR; + } + + if (gfc_match_omp_context_selector_specification (odv) != MATCH_YES) + return MATCH_ERROR; + + if (gfc_match (" )") != MATCH_YES) + { + gfc_error ("expected ')' at %C"); + return MATCH_ERROR; + } + + first_p = false; + } + + return MATCH_YES; +} + + match gfc_match_omp_threadprivate (void) { diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 7d765a0866d..2a454be79b0 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -26,6 +26,8 @@ along with GCC; see the file COPYING3. If not see #include #include "match.h" #include "parse.h" +#include "tree-core.h" +#include "omp-general.h" /* Current statement label. Zero means no statement label. Because new_st can get wiped during statement matching, we have to keep it separate. */ @@ -860,6 +862,8 @@ decode_omp_directive (void) ST_OMP_DECLARE_SIMD); matchdo ("declare target", gfc_match_omp_declare_target, ST_OMP_DECLARE_TARGET); + matchdo ("declare variant", gfc_match_omp_declare_variant, + ST_OMP_DECLARE_VARIANT); break; case 's': matchs ("simd", gfc_match_omp_simd, ST_OMP_SIMD); @@ -1718,6 +1722,7 @@ next_statement (void) #define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \ case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION: \ + case ST_OMP_DECLARE_VARIANT: \ case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE /* Block end statements. Errors associated with interchanging these @@ -2361,6 +2366,9 @@ gfc_ascii_statement (gfc_statement st) case ST_OMP_DECLARE_TARGET: p = "!$OMP DECLARE TARGET"; break; + case ST_OMP_DECLARE_VARIANT: + p = "!$OMP DECLARE VARIANT"; + break; case ST_OMP_DEPOBJ: p = "!$OMP DEPOBJ"; break; @@ -6793,6 +6801,24 @@ done: gfc_current_ns = gfc_current_ns->sibling) gfc_check_omp_requires (gfc_current_ns, omp_requires); + /* Populate omp_requires_mask (needed for resolving OpenMP + metadirectives and declare variant). */ + switch (omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK) + { + case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST: + omp_requires_mask + = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_SEQ_CST); + break; + case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL: + omp_requires_mask + = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_ACQ_REL); + break; + case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED: + omp_requires_mask + = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_RELAXED); + break; + } + /* Do the parse tree dump. */ gfc_current_ns = flag_dump_fortran_original ? gfc_global_ns_list : NULL; diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 6d61bf4982b..2c4acd5abe1 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -4046,6 +4046,7 @@ gfc_free_namespace (gfc_namespace *ns) free_tb_tree (ns->tb_uop_root); gfc_free_finalizer_list (ns->finalizers); gfc_free_omp_declare_simd_list (ns->omp_declare_simd); + gfc_free_omp_declare_variant_list (ns->omp_declare_variant); gfc_free_charlen (ns->cl_list, NULL); free_st_labels (ns->st_labels); diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index c758d26febf..7dd4c8d2063 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -3111,6 +3111,34 @@ gfc_create_function_decl (gfc_namespace * ns, bool global) if (ns->omp_declare_simd) gfc_trans_omp_declare_simd (ns); + + /* Move any 'declare variant' declarations from parent namespace to the + current namespace if the base name matches. */ + gfc_namespace *parent_ns = ns->parent; + while (parent_ns) + { + gfc_omp_declare_variant *prev = NULL, *next; + for (gfc_omp_declare_variant *odv = parent_ns->omp_declare_variant; + odv != NULL; odv = next) + { + if (odv->base_proc_symtree->n.sym == ns->proc_name) + { + if (prev == NULL) + parent_ns->omp_declare_variant = odv->next; + else + prev->next = odv->next; + odv->next = ns->omp_declare_variant; + ns->omp_declare_variant = odv; + } + else + prev = odv; + + next = odv->next; + } + parent_ns = parent_ns->parent; + } + if (ns->omp_declare_variant) + gfc_trans_omp_declare_variant (ns); } /* Return the decl used to hold the function return value. If diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index d234d1b070f..9da3309c27b 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -7258,3 +7258,139 @@ gfc_trans_omp_declare_simd (gfc_namespace *ns) DECL_ATTRIBUTES (fndecl) = c; } } + +void +gfc_trans_omp_declare_variant (gfc_namespace *ns) +{ + gfc_omp_declare_variant *odv; + + for (odv = ns->omp_declare_variant; odv; odv = odv->next) + { + tree set_selectors = NULL_TREE; + tree base_fn_decl = ns->proc_name->backend_decl; + gfc_omp_set_selector *oss; + + for (oss = odv->set_selectors; oss; oss = oss->next) + { + tree selectors = NULL_TREE; + gfc_omp_selector *os; + for (os = oss->trait_selectors; os; os = os->next) + { + tree properties = NULL_TREE; + gfc_omp_trait_property *otp; + + for (otp = os->properties; otp; otp = otp->next) + { + switch (otp->property_kind) + { + case CTX_PROPERTY_USER: + case CTX_PROPERTY_EXPR: + { + gfc_se se; + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, otp->expr); + properties = tree_cons (NULL_TREE, se.expr, + properties); + } + break; + case CTX_PROPERTY_ID: + properties = tree_cons (get_identifier (otp->name), + NULL_TREE, properties); + break; + case CTX_PROPERTY_NAME_LIST: + { + tree prop = NULL_TREE, value = NULL_TREE; + if (otp->is_name) + prop = get_identifier (otp->name); + else + value = gfc_conv_constant_to_tree (otp->expr); + + properties = tree_cons (prop, value, properties); + } + break; + case CTX_PROPERTY_SIMD: + properties = gfc_trans_omp_clauses (NULL, otp->clauses, + odv->where, true); + break; + default: + gcc_unreachable (); + } + } + + if (os->score) + { + gfc_se se; + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, os->score); + properties = tree_cons (get_identifier (" score"), + se.expr, properties); + } + + selectors = tree_cons (get_identifier (os->trait_selector_name), + properties, selectors); + } + + set_selectors + = tree_cons (get_identifier (oss->trait_set_selector_name), + selectors, set_selectors); + } + + const char *variant_proc_name = odv->variant_proc_symtree->name; + gfc_symbol *variant_proc_sym = odv->variant_proc_symtree->n.sym; + if (variant_proc_sym == NULL) + { + gfc_symtree *proc_st; + gfc_find_sym_tree (variant_proc_name, gfc_current_ns, 1, &proc_st); + variant_proc_sym = proc_st->n.sym; + } + if (variant_proc_sym == NULL) + { + gfc_error ("Cannot find symbol %qs", variant_proc_name); + continue; + } + set_selectors = omp_check_context_selector + (gfc_get_location (&odv->where), set_selectors); + if (set_selectors != error_mark_node) + { + if (!variant_proc_sym->attr.subroutine + && !variant_proc_sym->attr.function) + { + gfc_error ("variant %qs is not a function or subroutine", + variant_proc_name); + variant_proc_sym = NULL; + } + else if (omp_get_context_selector (set_selectors, "construct", + "simd") == NULL_TREE) + { + char err[256]; + if (!gfc_compare_interfaces (ns->proc_name, variant_proc_sym, + variant_proc_sym->name, 0, 1, + err, sizeof (err), NULL, NULL)) + { + gfc_error ("variant %qs and base %qs have incompatible " + "types: %s", + variant_proc_name, ns->proc_name->name, err); + variant_proc_sym = NULL; + } + } + if (variant_proc_sym != NULL) + { + gfc_set_sym_referenced (variant_proc_sym); + tree construct = omp_get_context_selector (set_selectors, + "construct", NULL); + omp_mark_declare_variant (gfc_get_location (&odv->where), + gfc_get_symbol_decl (variant_proc_sym), + construct); + if (omp_context_selector_matches (set_selectors)) + { + DECL_ATTRIBUTES (base_fn_decl) + = tree_cons ( + get_identifier ("omp declare variant base"), + build_tree_list (gfc_get_symbol_decl (variant_proc_sym), + set_selectors), + DECL_ATTRIBUTES (base_fn_decl)); + } + } + } + } +} 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/gimplify.c b/gcc/gimplify.c index b27776af7c8..6e8bb733412 100644 --- a/gcc/gimplify.c +++ b/gcc/gimplify.c @@ -11599,8 +11599,11 @@ omp_construct_selector_matches (enum tree_code *constructs, int nconstructs, } } if (!target_seen - && lookup_attribute ("omp declare target block", - DECL_ATTRIBUTES (current_function_decl))) + && (lookup_attribute ("omp declare target block", + DECL_ATTRIBUTES (current_function_decl)) + || (lang_GNU_Fortran () + && lookup_attribute ("omp declare target", + DECL_ATTRIBUTES (current_function_decl))))) { if (scores) codes.safe_push (OMP_TARGET); diff --git a/gcc/omp-general.c b/gcc/omp-general.c index 1e4c0b25531..5fcef77defc 100644 --- a/gcc/omp-general.c +++ b/gcc/omp-general.c @@ -1094,6 +1094,146 @@ omp_maybe_offloaded (void) return false; } + +/* Diagnose errors in an OpenMP context selector, return CTX if + it is correct or error_mark_node otherwise. */ + +tree +omp_check_context_selector (location_t loc, tree ctx) +{ + /* Each trait-set-selector-name can only be specified once. + There are just 4 set names. */ + for (tree t1 = ctx; t1; t1 = TREE_CHAIN (t1)) + for (tree t2 = TREE_CHAIN (t1); t2; t2 = TREE_CHAIN (t2)) + if (TREE_PURPOSE (t1) == TREE_PURPOSE (t2)) + { + error_at (loc, "selector set %qs specified more than once", + IDENTIFIER_POINTER (TREE_PURPOSE (t1))); + return error_mark_node; + } + for (tree t = ctx; t; t = TREE_CHAIN (t)) + { + /* Each trait-selector-name can only be specified once. */ + if (list_length (TREE_VALUE (t)) < 5) + { + for (tree t1 = TREE_VALUE (t); t1; t1 = TREE_CHAIN (t1)) + for (tree t2 = TREE_CHAIN (t1); t2; t2 = TREE_CHAIN (t2)) + if (TREE_PURPOSE (t1) == TREE_PURPOSE (t2)) + { + error_at (loc, + "selector %qs specified more than once in set %qs", + IDENTIFIER_POINTER (TREE_PURPOSE (t1)), + IDENTIFIER_POINTER (TREE_PURPOSE (t))); + return error_mark_node; + } + } + else + { + hash_set 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. */ @@ -1105,7 +1245,8 @@ omp_context_name_list_prop (tree prop) else { const char *ret = TREE_STRING_POINTER (TREE_VALUE (prop)); - if ((size_t) TREE_STRING_LENGTH (TREE_VALUE (prop)) == strlen (ret) + 1) + if ((size_t) TREE_STRING_LENGTH (TREE_VALUE (prop)) + == strlen (ret) + (lang_GNU_Fortran () ? 0 : 1)) return ret; return NULL; } diff --git a/gcc/omp-general.h b/gcc/omp-general.h index 6a1468d2798..8fe744c6a7a 100644 --- a/gcc/omp-general.h +++ b/gcc/omp-general.h @@ -104,6 +104,9 @@ extern tree find_combined_omp_for (tree *, int *, void *); extern poly_uint64 omp_max_vf (void); extern int omp_max_simt_vf (void); extern int omp_constructor_traits_to_codes (tree, enum tree_code *); +extern tree omp_check_context_selector (location_t loc, tree ctx); +extern void omp_mark_declare_variant (location_t loc, tree variant, + tree construct); extern int omp_context_selector_matches (tree); extern int omp_context_selector_set_compare (const char *, tree, tree); extern tree omp_get_context_selector (tree, const char *, const char *); diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-1.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-1.f90 new file mode 100644 index 00000000000..de09dbfe806 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-1.f90 @@ -0,0 +1,93 @@ +module main + implicit none + + interface + integer function foo (a, b, c) + integer, intent(in) :: a, b + integer, intent(inout) :: c + end function + + integer function bar (a, b, c) + integer, intent(in) :: a, b + integer, intent(inout) :: c + end function + + integer function baz (a, b, c) + integer, intent(in) :: a, b + integer, intent(inout) :: c + + !$omp declare variant (foo) & + !$omp & match (construct={parallel,do}, & + !$omp & device={isa(avx512f,avx512vl),kind(host,cpu)}, & + !$omp & implementation={vendor(score(0):gnu),unified_shared_memory}, & + !$omp & user={condition(score(0):0)}) + !$omp declare variant (bar) & + !$omp & match (device={arch(x86_64,powerpc64),isa(avx512f,popcntb)}, & + !$omp & implementation={atomic_default_mem_order(seq_cst),made_up_selector("foo", 13, "bar")}, & + !$omp & user={condition(3-3)}) + end function + + subroutine quux + end subroutine quux + + integer function baz3 (x, y, z) + integer, intent(in) :: x, y + integer, intent(inout) :: z + + !$omp declare variant (bar) match & + !$omp & (implementation={atomic_default_mem_order(score(3): acq_rel)}) + end function + end interface +contains + integer function qux () + integer :: i = 3 + + qux = baz (1, 2, i) + end function + + subroutine corge + integer :: i + !$omp declare variant (quux) match (construct={parallel,do}) + + interface + subroutine waldo (x) + integer, intent(in) :: x + end subroutine + end interface + + call waldo (5) + !$omp parallel do + do i = 1, 3 + call waldo (6) + end do + !$omp end parallel do + + !$omp parallel + !$omp taskgroup + !$omp do + do i = 1, 3 + call waldo (7) + end do + !$omp end do + !$omp end taskgroup + !$omp end parallel + + !$omp parallel + !$omp master + call waldo (8) + !$omp end master + !$omp end parallel + end subroutine + + integer function baz2 (x, y, z) + integer, intent(in) :: x, y + integer, intent(inout) :: z + + !$omp declare variant (bar) match & + !$omp & (implementation={atomic_default_mem_order(relaxed), & + !$omp & unified_address, unified_shared_memory, & + !$omp & dynamic_allocators, reverse_offload}) + + baz2 = x + y + z + end function +end module diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-10.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-10.f90 new file mode 100644 index 00000000000..d6d2c8c262b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-10.f90 @@ -0,0 +1,97 @@ +! { dg-do compile } +! { dg-additional-options "-cpp -foffload=disable -fdump-tree-gimple" } +! { dg-additional-options "-mavx512bw" { target { i?86-*-* x86_64-*-* } } } + +#undef i386 + +program main + !$omp declare target to (test3) +contains + subroutine f01 () + end subroutine + subroutine f02 () + !$omp declare variant (f01) match (device={isa(avx512f,avx512bw)}) + end subroutine + subroutine f03 () + end subroutine + subroutine f04 () + !$omp declare variant (f03) match (device={kind("any"),arch(x86_64),isa(avx512f,avx512bw)}) + end subroutine + subroutine f05 () + end subroutine + subroutine f06 () + !$omp declare variant (f05) match (device={kind(gpu)}) + end subroutine + subroutine f07 () + end subroutine + subroutine f08 () + !$omp declare variant (f07) match (device={kind(cpu)}) + end subroutine + subroutine f09 () + end subroutine + subroutine f10 () + !$omp declare variant (f09) match (device={isa(sm_35)}) + end subroutine + subroutine f11 () + end subroutine + subroutine f12 () + !$omp declare variant (f11) match (device={arch("nvptx")}) + end subroutine + subroutine f13 () + end subroutine + subroutine f14 () + !$omp declare variant (f13) match (device={arch(i386),isa("sse4")}) + end subroutine + subroutine f15 () + end subroutine + subroutine f16 () + !$omp declare variant (f15) match (device={isa(sse4,ssse3),arch(i386)}) + end subroutine + subroutine f17 () + end subroutine + subroutine f18 () + !$omp declare variant (f17) match (device={kind(any,fpga)}) + end subroutine + + subroutine test1 () + !$omp declare target + integer :: i + + call f02 () ! { dg-final { scan-tree-dump-times "f01 \\\(\\\);" 1 "gimple" { target i?86-*-* x86_64-*-* } } } + ! { dg-final { scan-tree-dump-times "f02 \\\(\\\);" 1 "gimple" { target { ! { i?86-*-* x86_64-*-* } } } } } + call f14 () ! { dg-final { scan-tree-dump-times "f13 \\\(\\\);" 1 "gimple" { target ia32 } } } + ! { dg-final { scan-tree-dump-times "f14 \\\(\\\);" 1 "gimple" { target { ! ia32 } } } } + call f18 () ! { dg-final { scan-tree-dump-times "f18 \\\(\\\);" 1 "gimple" } } */ + end subroutine + +#if defined(__i386__) || defined(__x86_64__) + __attribute__((target ("avx512f,avx512bw"))) +#endif + subroutine test2 () + !$omp target + call f04 () ! { dg-final { scan-tree-dump-times "f03 \\\(\\\);" 1 "gimple" { target { { i?86-*-* x86_64-*-* } && lp64 } } } } + ! { dg-final { scan-tree-dump-times "f04 \\\(\\\);" 1 "gimple" { target { { ! lp64 } || { ! { i?86-*-* x86_64-*-* } } } } } } + !$omp end target + !$omp target + call f16 () ! { dg-final { scan-tree-dump-times "f15 \\\(\\\);" 1 "gimple" { target ia32 } } } + ! { dg-final { scan-tree-dump-times "f16 \\\(\\\);" 1 "gimple" { target { ! ia32 } } } } + !$omp end target + end subroutine + + subroutine test3 () + call f06 () ! { dg-final { scan-tree-dump-times "f06 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* amdgcn*-*-* } } } } } + call f08 () ! { dg-final { scan-tree-dump-times "f07 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* amdgcn*-*-* } } } } } + end subroutine + + subroutine test4 () + !$omp target + call f10 () ! { dg-final { scan-tree-dump-times "f10 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* amdgcn*-*-* } } } } } + !$omp end target + + !$omp target + call f12 () ! { dg-final { scan-tree-dump-times "f12 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* } } } } } + ! { dg-final { scan-tree-dump-times "f11 \\\(\\\);" 1 "gimple" { target { nvptx*-*-* } } } } + !$omp end target + end subroutine +end program + diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-11.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-11.f90 new file mode 100644 index 00000000000..60aa0fcb3b0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-11.f90 @@ -0,0 +1,134 @@ +! { dg-do compile } +! { dg-additional-options "-foffload=disable -fdump-tree-gimple" } +! { dg-additional-options "-mavx512bw -mavx512vl" { target { i?86-*-* x86_64-*-* } } } + +program main + implicit none +contains + subroutine f01 () + end subroutine + + subroutine f02 () + end subroutine + + subroutine f03 () + !$omp declare variant (f01) match (device={isa(avx512f,"avx512vl")}) + !$omp declare variant (f02) match (device={isa(avx512bw,avx512vl,"avx512f")}) + end subroutine + + subroutine f04 () + end subroutine + + subroutine f05 () + end subroutine + + subroutine f06 () + !$omp declare variant (f04) match (device={isa(avx512f,avx512vl)}) + !$omp declare variant (f05) match (device={isa(avx512bw,avx512vl,avx512f)}) + end subroutine + + subroutine f07 () + end subroutine + + subroutine f08 () + end subroutine + + subroutine f09 () + !$omp declare variant (f07) match (device={isa(sse4,"sse4.1","sse4.2",sse3,"avx")}) + !$omp declare variant (f08) match (device={isa("avx",sse3)}) + end subroutine + + subroutine f10 () + end subroutine + + subroutine f11 () + end subroutine + + subroutine f12 () + end subroutine + + subroutine f13 () + !$omp declare variant (f10) match (device={isa("avx512f")}) + !$omp declare variant (f11) match (user={condition(1)},device={isa(avx512f)},implementation={vendor(gnu)}) + !$omp declare variant (f12) match (user={condition(2 + 1)},device={isa(avx512f)}) + end subroutine + + subroutine f14 () + end subroutine + + subroutine f15 () + end subroutine + + subroutine f16 () + end subroutine + + subroutine f17 () + end subroutine + + subroutine f18 () + !$omp declare variant (f14) match (construct={teams,do}) + !$omp declare variant (f15) match (construct={teams,parallel,do}) + !$omp declare variant (f16) match (construct={do}) + !$omp declare variant (f17) match (construct={parallel,do}) + end subroutine + + subroutine f19 () + end subroutine + + subroutine f20 () + end subroutine + + subroutine f21 () + end subroutine + + subroutine f22 () + end subroutine + + subroutine f23 () + !$omp declare variant (f19) match (construct={teams,do}) + !$omp declare variant (f20) match (construct={teams,parallel,do}) + !$omp declare variant (f21) match (construct={do}) + !$omp declare variant (f22) match (construct={parallel,do}) + end subroutine + + subroutine f24 () + end subroutine + + subroutine f25 () + end subroutine + + subroutine f26 () + end subroutine + + subroutine f27 () + !$omp declare variant (f24) match (device={kind(cpu)}) + !$omp declare variant (f25) match (device={kind(cpu),isa(avx512f),arch(x86_64)}) + !$omp declare variant (f26) match (device={arch(x86_64),kind(cpu)}) + end subroutine + + subroutine test1 + integer :: i + call f03 () ! { dg-final { scan-tree-dump-times "f02 \\\(\\\);" 1 "gimple" { target i?86-*-* x86_64-*-* } } } + ! { dg-final { scan-tree-dump-times "f03 \\\(\\\);" 1 "gimple" { target { ! { i?86-*-* x86_64-*-* } } } } } + call f09 () ! { dg-final { scan-tree-dump-times "f07 \\\(\\\);" 1 "gimple" { target i?86-*-* x86_64-*-* } } } + ! { dg-final { scan-tree-dump-times "f09 \\\(\\\);" 1 "gimple" { target { ! { i?86-*-* x86_64-*-* } } } } } + call f13 () ! { dg-final { scan-tree-dump-times "f11 \\\(\\\);" 1 "gimple" { target i?86-*-* x86_64-*-* } } } + ! { dg-final { scan-tree-dump-times "f13 \\\(\\\);" 1 "gimple" { target { ! { i?86-*-* x86_64-*-* } } } } } + !$omp teams distribute parallel do + do i = 1, 2 + call f18 () ! { dg-final { scan-tree-dump-times "f15 \\\(\\\);" 1 "gimple" } } + end do + !$omp end teams distribute parallel do + + !$omp parallel do + do i = 1, 2 + call f23 () ! { dg-final { scan-tree-dump-times "f22 \\\(\\\);" 1 "gimple" } } + end do + !$omp end parallel do + + call f27 () ! { dg-final { scan-tree-dump-times "f25 \\\(\\\);" 1 "gimple" { target { { i?86-*-* x86_64-*-* } && lp64 } } } } + ! { dg-final { scan-tree-dump-times "f24 \\\(\\\);" 1 "gimple" { target { { i?86-*-* x86_64-*-* } && { ! lp64 } } } } } + ! { dg-final { scan-tree-dump-times "f24 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* amdgcn*-*-* i?86-*-* x86_64-*-* } } } } } + ! { dg-final { scan-tree-dump-times "f27 \\\(\\\);" 1 "gimple" { target { nvptx*-*-* amdgcn*-*-* } } } } + end subroutine +end program diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-12.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-12.f90 new file mode 100644 index 00000000000..610693e9807 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-12.f90 @@ -0,0 +1,159 @@ +! { dg-do compile } +! { dg-additional-options "-foffload=disable -fdump-tree-gimple" } +! { dg-additional-options "-mavx512bw -mavx512vl" { target { i?86-*-* x86_64-*-* } } } + +program main + !$omp requires atomic_default_mem_order(seq_cst) +contains + subroutine f01 () + end subroutine + + subroutine f02 () + end subroutine + + subroutine f03 () + end subroutine + + subroutine f04 () + !$omp declare variant (f01) match (device={isa("avx512f","avx512vl")}) ! 16 + !$omp declare variant (f02) match (implementation={vendor(score(15):gnu)}) + !$omp declare variant (f03) match (user={condition(score(11):1)}) + end subroutine + + subroutine f05 () + end subroutine + + subroutine f06 () + end subroutine + + subroutine f07 () + end subroutine + + subroutine f08 () + !$omp declare variant (f05) match (device={isa(avx512f,avx512vl)}) ! 16 + !$omp declare variant (f06) match (implementation={vendor(score(15):gnu)}) + !$omp declare variant (f07) match (user={condition(score(17):1)}) + end subroutine + + subroutine f09 () + end subroutine + + subroutine f10 () + end subroutine + + subroutine f11 () + end subroutine + + subroutine f12 () + end subroutine + + subroutine f13 () + !$omp declare variant (f09) match (device={arch(x86_64)},user={condition(score(65):1)}) ! 64+65 + !$omp declare variant (f10) match (implementation={vendor(score(127):"gnu")}) + !$omp declare variant (f11) match (device={isa(ssse3)}) ! 128 + !$omp declare variant (f12) match (implementation={atomic_default_mem_order(score(126):seq_cst)}) + end subroutine + + subroutine f14 () + end subroutine + + subroutine f15 () + end subroutine + + subroutine f16 () + end subroutine + + subroutine f17 () + !$omp declare variant (f14) match (construct={teams,parallel,do}) ! 16+8+4 + !$omp declare variant (f15) match (construct={parallel},user={condition(score(19):1)}) ! 8+19 + !$omp declare variant (f16) match (implementation={atomic_default_mem_order(score(27):seq_cst)}) + end subroutine + + subroutine f18 () + end subroutine + + subroutine f19 () + end subroutine + + subroutine f20 () + end subroutine + + subroutine f21 () + !$omp declare variant (f18) match (construct={teams,parallel,do}) ! 16+8+4 + !$omp declare variant (f19) match (construct={do},user={condition(score(25):1)}) ! 4+25 + !$omp declare variant (f20) match (implementation={atomic_default_mem_order(score(28):seq_cst)}) + end subroutine + + subroutine f22 () + end subroutine + + subroutine f23 () + end subroutine + + subroutine f24 () + end subroutine + + subroutine f25 () + !$omp declare variant (f22) match (construct={parallel,do}) ! 2+1 + !$omp declare variant (f23) match (construct={do}) ! 0 + !$omp declare variant (f24) match (implementation={atomic_default_mem_order(score(2):seq_cst)}) + end subroutine + + subroutine f26 () + end subroutine + + subroutine f27 () + end subroutine + + subroutine f28 () + end subroutine + + subroutine f29 () + !$omp declare variant (f26) match (construct={parallel,do}) ! 2+1 + !$omp declare variant (f27) match (construct={do},user={condition(1)}) ! 4 + !$omp declare variant (f28) match (implementation={atomic_default_mem_order(score(3):seq_cst)}) + end subroutine + + subroutine test1 () + integer :: i, j + + !$omp parallel do ! 2 constructs in OpenMP context, isa has score 2^4. + do i = 1, 2 + call f04 () ! { dg-final { scan-tree-dump-times "f01 \\\(\\\);" 1 "gimple" { target i?86-*-* x86_64-*-* } } } + ! { dg-final { scan-tree-dump-times "f02 \\\(\\\);" 1 "gimple" { target { ! { i?86-*-* x86_64-*-* } } } } } + end do + !$omp end parallel do + + !$omp target teams ! 2 constructs in OpenMP context, isa has score 2^4. + call f08 () ! { dg-final { scan-tree-dump-times "f07 \\\(\\\);" 1 "gimple" } } + !$omp end target teams + + !$omp teams + !$omp parallel do + do i = 1, 2 + !$omp parallel do ! 5 constructs in OpenMP context, arch is 2^6, isa 2^7. + do j = 1, 2 + call f13 () ! { dg-final { scan-tree-dump-times "f09 \\\(\\\);" 1 "gimple" { target { { i?86-*-* x86_64-*-* } && lp64 } } } } + ! { dg-final { scan-tree-dump-times "f11 \\\(\\\);" 1 "gimple" { target { { i?86-*-* x86_64-*-* } && { ! lp64 } } } } } + ! { dg-final { scan-tree-dump-times "f10 \\\(\\\);" 1 "gimple" { target { ! { i?86-*-* x86_64-*-* } } } } } + call f17 () ! { dg-final { scan-tree-dump-times "f14 \\\(\\\);" 1 "gimple" } } + call f21 () ! { dg-final { scan-tree-dump-times "f19 \\\(\\\);" 1 "gimple" } } + end do + !$omp end parallel do + end do + !$omp end parallel do + !$omp end teams + + !$omp do + do i = 1, 2 + !$omp parallel do + do j = 1, 2 + call f25 (); ! { dg-final { scan-tree-dump-times "f22 \\\(\\\);" 1 "gimple" } } + call f29 (); ! { dg-final { scan-tree-dump-times "f27 \\\(\\\);" 1 "gimple" } } + end do + !$omp end parallel do + end do + !$omp end do + end subroutine +end program + diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-13.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-13.f90 new file mode 100644 index 00000000000..91648f9bcf4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-13.f90 @@ -0,0 +1,48 @@ +! { dg-do compile { target vect_simd_clones } } +! { dg-additional-options "-fdump-tree-gimple" } +! { dg-additional-options "-mno-sse3" { target { i?86-*-* x86_64-*-* } } } + +program main + implicit none +contains + integer function f01 (x) + integer, intent(in) :: x + f01 = x + end function + + integer function f02 (x) + integer, intent(in) :: x + f02 = x + end function + + integer function f03 (x) + integer, intent(in) :: x + f03 = x + end function + + integer function f04 (x) + integer, intent(in) :: x + f04 = x + end function + + integer function f05 (x) + integer, intent(in) :: x + + !$omp declare variant (f01) match (device={isa("avx512f")}) ! 4 or 8 + !$omp declare variant (f02) match (implementation={vendor(score(3):gnu)},device={kind(cpu)}) ! (1 or 2) + 3 + !$omp declare variant (f03) match (user={condition(score(9):1)}) + !$omp declare variant (f04) match (implementation={vendor(score(6):gnu)},device={kind(host)}) ! (1 or 2) + 6 + f05 = x + end function + + integer function test1 (x) + !$omp declare simd + integer, intent(in) :: x + + ! 0 or 1 (the latter if in a declare simd clone) constructs in OpenMP context, + ! isa has score 2^2 or 2^3. We can't decide on whether avx512f will match or + ! not, that also depends on whether it is a declare simd clone or not and which + ! one, but the f03 variant has a higher score anyway. */ + test1 = f05 (x) ! { dg-final { scan-tree-dump-times "f03 \\\(x" 1 "gimple" } } + end function +end program diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-14.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-14.f90 new file mode 100644 index 00000000000..06c9a5d1ed8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-14.f90 @@ -0,0 +1,49 @@ +! { dg-do compile { target vect_simd_clones } } +! { dg-additional-options "-O0 -fdump-tree-gimple -fdump-tree-optimized" } +! { dg-additional-options "-mno-sse3" { target { i?86-*-* x86_64-*-* } } } + +module main + implicit none +contains + integer function f01 (x) + integer, intent (in) :: x + f01 = x + end function + + integer function f02 (x) + integer, intent (in) :: x + f02 = x + end function + + integer function f03 (x) + integer, intent (in) :: x + f03 = x + end function + + integer function f04 (x) + integer, intent(in) :: x + + !$omp declare variant (f01) match (device={isa("avx512f")}) ! 4 or 8 + !$omp declare variant (f02) match (implementation={vendor(score(3):gnu)},device={kind(cpu)}) ! (1 or 2) + 3 + !$omp declare variant (f03) match (implementation={vendor(score(5):gnu)},device={kind(host)}) ! (1 or 2) + 5 + f04 = x + end function + + integer function test1 (x) + !$omp declare simd + integer, intent (in) :: x + integer :: a, b + + ! At gimplification time, we can't decide yet which function to call. + ! { dg-final { scan-tree-dump-times "f04 \\\(x" 2 "gimple" } } + ! After simd clones are created, the original non-clone test1 shall + ! call f03 (score 6), the sse2/avx/avx2 clones too, but avx512f clones + ! shall call f01 with score 8. + ! { dg-final { scan-tree-dump-not "f04 \\\(x" "optimized" } } + ! { dg-final { scan-tree-dump-times "f03 \\\(x" 14 "optimized" } } + ! { dg-final { scan-tree-dump-times "f01 \\\(x" 4 "optimized" } } + a = f04 (x) + b = f04 (x) + test1 = a + b + end function +end module diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-15.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-15.f90 new file mode 100644 index 00000000000..f8bc5f91d2d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-15.f90 @@ -0,0 +1,23 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-gimple" } + +! Test 'declare variant' directive with an explicit base procedure name. + +module main + implicit none + + !$omp declare variant (base: variant) match (construct={target,parallel}) +contains + subroutine variant () + end subroutine + + subroutine base () + end subroutine + + subroutine test2 () + !$omp declare target + !$omp parallel + call base () ! { dg-final { scan-tree-dump-times "variant \\\(\\\);" 1 "gimple" } } + !$omp end parallel + end subroutine +end module 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..2fe41c0650d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-8.f90 @@ -0,0 +1,210 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-gimple" } + +program main + !$omp requires atomic_default_mem_order(seq_cst) + !$omp declare target to (test3) +contains + subroutine f01 () + end subroutine + + subroutine f02 () + !$omp declare variant (f01) match (user={condition(6 == 7)},implementation={vendor(gnu)}) + end subroutine + + subroutine f03 () + end subroutine + + subroutine f04 () + !$omp declare variant (f03) match (user={condition(6 == 6)},implementation={atomic_default_mem_order(seq_cst)}) + end subroutine + + subroutine f05 () + end subroutine + + subroutine f06 () + !$omp declare variant (f05) match (user={condition(1)},implementation={atomic_default_mem_order(relaxed)}) + end subroutine + + subroutine f07 () + end subroutine + + subroutine f08 () + !$omp declare variant (f07) match (construct={parallel,do},device={kind("any")}) + end subroutine + + subroutine f09 () + end subroutine + + subroutine f10 () + !$omp declare variant (f09) match (construct={parallel,do},implementation={vendor("gnu")}) + end subroutine + + subroutine f11 () + end subroutine + + subroutine f12 () + !$omp declare variant (f11) match (construct={parallel,do}) + end subroutine + + subroutine f13 () + end subroutine + + subroutine f14 () + !$omp declare variant (f13) match (construct={parallel,do}) + end subroutine + + subroutine f15 () + !$omp declare target to (f13, f14) + end subroutine + + subroutine f16 () + !$omp declare variant (f15) match (implementation={vendor(llvm)}) + end subroutine + + subroutine f17 () + end subroutine + + subroutine f18 () + !$omp declare variant (f17) match (construct={target,parallel}) + end subroutine + + subroutine f19 () + end subroutine + + subroutine f20 () + !$omp declare variant (f19) match (construct={target,parallel}) + end subroutine + + subroutine f22 () + !$omp declare variant (f21) match (construct={teams,parallel}) + end subroutine + + subroutine f23 () + end subroutine + + subroutine f24 () + !$omp declare variant (f23) match (construct={teams,parallel,do}) + end subroutine + + subroutine f25 () + end subroutine + + subroutine f27 () + end subroutine + + subroutine f28 () + !$omp declare variant (f27) match (construct={teams,parallel,do}) + end subroutine + + subroutine f30 () + !$omp declare variant (f29) match (implementation={vendor(gnu)}) + end subroutine + + subroutine f31 () + end subroutine + + subroutine f32 () + !$omp declare variant (f31) match (construct={teams,parallel,do}) + end subroutine + + subroutine f33 () + end subroutine + + subroutine f34 () + !$omp declare variant (f33) match (device={kind("any\0any")}) ! { dg-warning "unknown property '.any..0any.' of 'kind' selector" } + end subroutine + + subroutine f35 () + end subroutine + + subroutine f36 () + !$omp declare variant (f35) match (implementation={vendor("gnu\0")}) ! { dg-warning "unknown property '.gnu..0.' of 'vendor' selector" } + end subroutine + + subroutine test1 () + integer :: i + + call f02 () ! { dg-final { scan-tree-dump-times "f02 \\\(\\\);" 1 "gimple" } } + call f04 () ! { dg-final { scan-tree-dump-times "f03 \\\(\\\);" 1 "gimple" } } + call f06 () ! { dg-final { scan-tree-dump-times "f06 \\\(\\\);" 1 "gimple" } } + + !$omp parallel + !$omp do + do i = 1, 2 + call f08 () ! { dg-final { scan-tree-dump-times "f07 \\\(\\\);" 1 "gimple" } } + end do + !$omp end do + !$omp end parallel + + !$omp parallel do + do i = 1, 2 + call f10 () ! { dg-final { scan-tree-dump-times "f09 \\\(\\\);" 1 "gimple" } } + end do + !$omp end parallel do + + !$omp do + do i = 1, 2 + !$omp parallel + call f12 () ! { dg-final { scan-tree-dump-times "f12 \\\(\\\);" 1 "gimple" } } + !$omp end parallel + end do + !$omp end do + + !$omp parallel + !$omp target + !$omp do + do i = 1, 2 + call f14 () ! { dg-final { scan-tree-dump-times "f14 \\\(\\\);" 1 "gimple" } } + end do + !$omp end do + !$omp end target + !$omp end parallel + + call f16 () ! { dg-final { scan-tree-dump-times "f16 \\\(\\\);" 1 "gimple" } } + call f34 () ! { dg-final { scan-tree-dump-times "f34 \\\(\\\);" 1 "gimple" } } + call f36 () ! { dg-final { scan-tree-dump-times "f36 \\\(\\\);" 1 "gimple" } } + end subroutine + + subroutine test2 () + !$omp declare target + !$omp parallel + call f18 () ! { dg-final { scan-tree-dump-times "f17 \\\(\\\);" 1 "gimple" } } + !$omp end parallel + end subroutine + + subroutine test3 () + !$omp parallel + call f20 () ! { dg-final { scan-tree-dump-times "f20 \\\(\\\);" 1 "gimple" { xfail *-*-* } } } + !$omp end parallel + end subroutine + + subroutine f21 () + integer :: i + !$omp do + do i = 1, 2 + call f24 () ! { dg-final { scan-tree-dump-times "f23 \\\(\\\);" 1 "gimple" } } + end do + !$omp end do + end subroutine + + subroutine f26 () + !$omp declare variant (f25) match (construct={teams,parallel}) + + integer :: i + !$omp do + do i = 1, 2 + call f28 () ! { dg-final { scan-tree-dump-times "f28 \\\(\\\);" 1 "gimple" } } + end do + !$omp end do + end subroutine + + subroutine f29 () + integer :: i + !$omp do + do i = 1, 2 + call f32 () ! { dg-final { scan-tree-dump-times "f32 \\\(\\\);" 1 "gimple" } } + end do + !$omp end do + end subroutine +end program diff --git a/gcc/testsuite/gfortran.dg/gomp/declare-variant-9.f90 b/gcc/testsuite/gfortran.dg/gomp/declare-variant-9.f90 new file mode 100644 index 00000000000..ebd066609f3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/declare-variant-9.f90 @@ -0,0 +1,58 @@ +! { dg-do compile } +! { dg-additional-options "-cpp -fdump-tree-gimple" } +! { dg-additional-options "-mno-sse3" { target { i?86-*-* x86_64-*-* } } } + +program main + implicit none +contains + subroutine f01 () + end subroutine + subroutine f02 () + !$omp declare variant (f01) match (device={isa("avx512f",avx512bw)}) + end subroutine + subroutine f05 () + end subroutine + subroutine f06 () + !$omp declare variant (f05) match (device={kind(gpu)}) + end subroutine + subroutine f07 () + end subroutine + subroutine f08 () + !$omp declare variant (f07) match (device={kind("cpu")}) + end subroutine + subroutine f09 () + end subroutine + subroutine f10 () + !$omp declare variant (f09) match (device={isa(sm_35)}) + end subroutine + subroutine f11 () + end subroutine + subroutine f12 () + !$omp declare variant (f11) match (device={arch(nvptx)}) + end subroutine + subroutine f13 () + end subroutine + subroutine f14 () + !$omp declare variant (f13) match (device={arch("i386"),isa(sse4)}) + end subroutine + subroutine f17 () + end subroutine + subroutine f18 () + !$omp declare variant (f17) match (device={kind("any","fpga")}) + end subroutine + + subroutine test1 () + integer :: i; + call f02 () ! { dg-final { scan-tree-dump-times "f02 \\\(\\\);" 1 "gimple" } } + call f14 () ! { dg-final { scan-tree-dump-times "f14 \\\(\\\);" 1 "gimple" } } + call f18 () ! { dg-final { scan-tree-dump-times "f18 \\\(\\\);" 1 "gimple" } } + end subroutine + + subroutine test3 () + call f06 () ! { dg-final { scan-tree-dump-times "f06 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* amdgcn*-*-* } } } } } + call f08 () ! { dg-final { scan-tree-dump-times "f07 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* amdgcn*-*-* } } } } } + call f10 () ! { dg-final { scan-tree-dump-times "f10 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* amdgcn*-*-* } } } } } + call f12 () ! { dg-final { scan-tree-dump-times "f12 \\\(\\\);" 1 "gimple" { target { ! { nvptx*-*-* } } } } } + ! { dg-final { scan-tree-dump-times "f11 \\\(\\\);" 1 "gimple" { target { nvptx*-*-* } } } } + end subroutine +end program diff --git a/libgomp/testsuite/libgomp.fortran/declare-variant-1.f90 b/libgomp/testsuite/libgomp.fortran/declare-variant-1.f90 new file mode 100644 index 00000000000..e6f69dccb49 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/declare-variant-1.f90 @@ -0,0 +1,33 @@ +! { dg-do run } + +program main + implicit none + + integer :: v + !$omp target map(from:v) + v = on () + !$omp end target + + select case (v) + case default + write (*,*) "Host fallback or unknown offloading" + case (1) + write (*,*) "Offloading to NVidia PTX" + case (2) + write (*,*) "Offloading to AMD GCN" + end select +contains + integer function on_nvptx () + on_nvptx = 1 + end function + + integer function on_gcn () + on_gcn = 2 + end function + + integer function on () + !$omp declare variant (on_nvptx) match(construct={target},device={arch(nvptx)}) + !$omp declare variant (on_gcn) match(construct={target},device={arch(gcn)}) + on = 0 + end function +end program