From patchwork Mon Jul 17 13:26:27 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 1808765 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@legolas.ozlabs.org Authentication-Results: legolas.ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=server2.sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Received: from server2.sourceware.org (server2.sourceware.org [8.43.85.97]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature ECDSA (P-384) server-digest SHA384) (No client certificate requested) by legolas.ozlabs.org (Postfix) with ESMTPS id 4R4NCj6kkVz20FK for ; Mon, 17 Jul 2023 23:26:57 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id C4457385AF96 for ; Mon, 17 Jul 2023 13:26:55 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from esa2.mentor.iphmx.com (esa2.mentor.iphmx.com [68.232.141.98]) by sourceware.org (Postfix) with ESMTPS id 829C33858024; Mon, 17 Jul 2023 13:26:35 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 829C33858024 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com X-IronPort-AV: E=Sophos;i="6.01,211,1684828800"; d="diff'?scan'208";a="13476366" Received: from orw-gwy-01-in.mentorg.com ([192.94.38.165]) by esa2.mentor.iphmx.com with ESMTP; 17 Jul 2023 05:26:33 -0800 IronPort-SDR: 8YNraH8PH/iKDFZ9RPQhdEc+3cM4QgfvAHyWq9f3HyFEMbKKVjA47FsV0RMDDRWRIE2j/YjirK eWy9L0Yv6ogUMlBfuMikeR3GlMnlpAWvVoFtn/g4nwM3hrDFrrg1NxIBpt4yqgjzF3U8qDAzLW 0DB4hsHLzKYXUZDyYsCrvs9BDbauT2sa7X4qgR7+Nfff+A5OsIvHavMljKho5V3WIx35mYNzt2 PwnNAvzleOK0jhN2qSPLfXPdK5PWAfJgNIPXstOUFMuq7PJaF+SKhuKPlgnvlzyGTNta2JAPTU nyM= Message-ID: <7e45d213-5687-43b0-061c-f88ef9b67806@codesourcery.com> Date: Mon, 17 Jul 2023 15:26:27 +0200 MIME-Version: 1.0 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:102.0) Gecko/20100101 Thunderbird/102.13.0 Content-Language: en-US To: gcc-patches , fortran From: Tobias Burnus Subject: [committed] OpenMP/Fortran: Parsing support for 'uses_allocators' X-Originating-IP: [137.202.0.90] X-ClientProxiedBy: svr-ies-mbx-15.mgc.mentorg.com (139.181.222.15) To svr-ies-mbx-12.mgc.mentorg.com (139.181.222.12) X-Spam-Status: No, score=-11.3 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, KAM_SHORT, SPF_HELO_PASS, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) 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+incoming=patchwork.ozlabs.org@gcc.gnu.org Sender: "Gcc-patches" Committed the attached patch as r14-2582-g89d0f082b3c95f. This is about OpenMP's uses_allocators clause to the 'target' directive. Using the clause with predefined allocators as list arguments is required if those allocators are used in a target region - unless there is an 'omp requires dynamic_allocators' in the compilation unit. While the later is a no op (requirement fulfilled by all devices), we still had to handle the no op when using 'uses_allocators', which this commit does. However, uses_allocators also permits to define new allocators; for those, this commit stops after parsing and resolving with a 'sorry, unimplemented'. Support for the latter will be added together with the C/C++ support by a re-diffed/updated version of Chung-Lin's patch at https://gcc.gnu.org/pipermail/gcc-patches/2022-June/596587.html (See thread for pending review issues; the C++ member var issue is https://gcc.gnu.org/PR110347 ) Tobias ----------------- Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955 commit 89d0f082b3c95f68d116d4480126e3ab7fb7f36b Author: Tobias Burnus Date: Mon Jul 17 15:13:44 2023 +0200 OpenMP/Fortran: Parsing support for 'uses_allocators' The 'uses_allocators' clause to the 'target' construct accepts predefined allocators and can also be used to define a new allocator for a target region. As predefined allocators in GCC do not require special handling, those can and are ignored after parsing, such that this feature now works. On the other hand, defining a new allocator will fail for now with a 'sorry, unimplemented'. Note that both the OpenMP 5.0/5.1 and 5.2 syntax for uses_allocators is supported by this commit. 2023-07-17 Tobias Burnus Chung-Lin Tang gcc/fortran/ChangeLog: * dump-parse-tree.cc (show_omp_namelist, show_omp_clauses): Dump uses_allocators clause. * gfortran.h (gfc_free_omp_namelist): Add memspace_sym to u union and traits_sym to u2 union. (OMP_LIST_USES_ALLOCATORS): New enum value. (gfc_free_omp_namelist): Add 'bool free_mem_traits_space' arg. * match.cc (gfc_free_omp_namelist): Likewise. * openmp.cc (gfc_free_omp_clauses, gfc_match_omp_variable_list, gfc_match_omp_to_link, gfc_match_omp_doacross_sink, gfc_match_omp_clause_reduction, gfc_match_omp_allocate, gfc_match_omp_flush): Update call. (gfc_match_omp_clauses): Likewise. Parse uses_allocators clause. (gfc_match_omp_clause_uses_allocators): New. (enum omp_mask2): Add new OMP_CLAUSE_USES_ALLOCATORS. (OMP_TARGET_CLAUSES): Accept it. (resolve_omp_clauses): Resolve uses_allocators clause * st.cc (gfc_free_statement): Update gfc_free_omp_namelist call. * trans-openmp.cc (gfc_trans_omp_clauses): Handle OMP_LIST_USES_ALLOCATORS; fail with sorry unless predefined allocator. (gfc_split_omp_clauses): Handle uses_allocators. libgomp/ChangeLog: * testsuite/libgomp.fortran/uses_allocators_1.f90: New test. * testsuite/libgomp.fortran/uses_allocators_2.f90: New test. Co-authored-by: Chung-Lin Tang --- gcc/fortran/dump-parse-tree.cc | 24 +++ gcc/fortran/gfortran.h | 5 +- gcc/fortran/match.cc | 7 +- gcc/fortran/openmp.cc | 194 +++++++++++++++++++-- gcc/fortran/st.cc | 2 +- gcc/fortran/trans-openmp.cc | 11 ++ .../libgomp.fortran/uses_allocators_1.f90 | 168 ++++++++++++++++++ .../libgomp.fortran/uses_allocators_2.f90 | 99 +++++++++++ 8 files changed, 491 insertions(+), 19 deletions(-) diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc index effcebe9325..68122e3e6fd 100644 --- a/gcc/fortran/dump-parse-tree.cc +++ b/gcc/fortran/dump-parse-tree.cc @@ -1497,6 +1497,29 @@ show_omp_namelist (int list_type, gfc_omp_namelist *n) case OMP_LINEAR_UVAL: fputs ("uval(", dumpfile); break; default: break; } + else if (list_type == OMP_LIST_USES_ALLOCATORS) + { + if (n->u.memspace_sym) + { + fputs ("memspace(", dumpfile); + fputs (n->sym->name, dumpfile); + fputc (')', dumpfile); + } + if (n->u.memspace_sym && n->u2.traits_sym) + fputc (',', dumpfile); + if (n->u2.traits_sym) + { + fputs ("traits(", dumpfile); + fputs (n->u2.traits_sym->name, dumpfile); + fputc (')', dumpfile); + } + if (n->u.memspace_sym || n->u2.traits_sym) + fputc (':', dumpfile); + fputs (n->sym->name, dumpfile); + if (n->next) + fputs (", ", dumpfile); + continue; + } fprintf (dumpfile, "%s", n->sym ? n->sym->name : "omp_all_memory"); if (list_type == OMP_LIST_LINEAR && n->u.linear.op != OMP_LINEAR_DEFAULT) fputc (')', dumpfile); @@ -1799,6 +1822,7 @@ show_omp_clauses (gfc_omp_clauses *omp_clauses) case OMP_LIST_ALLOCATE: type = "ALLOCATE"; break; case OMP_LIST_SCAN_IN: type = "INCLUSIVE"; break; case OMP_LIST_SCAN_EX: type = "EXCLUSIVE"; break; + case OMP_LIST_USES_ALLOCATORS: type = "USES_ALLOCATORS"; break; default: gcc_unreachable (); } diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 74466c7f04c..6482a885211 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1368,6 +1368,7 @@ typedef struct gfc_omp_namelist bool old_modifier; } linear; struct gfc_common_head *common; + struct gfc_symbol *memspace_sym; bool lastprivate_conditional; bool present_modifier; } u; @@ -1376,6 +1377,7 @@ typedef struct gfc_omp_namelist struct gfc_omp_namelist_udr *udr; gfc_namespace *ns; gfc_expr *allocator; + struct gfc_symbol *traits_sym; } u2; struct gfc_omp_namelist *next; locus where; @@ -1419,6 +1421,7 @@ enum OMP_LIST_ALLOCATE, OMP_LIST_HAS_DEVICE_ADDR, OMP_LIST_ENTER, + OMP_LIST_USES_ALLOCATORS, OMP_LIST_NUM /* Must be the last. */ }; @@ -3600,7 +3603,7 @@ void gfc_free_iterator (gfc_iterator *, int); void gfc_free_forall_iterator (gfc_forall_iterator *); void gfc_free_alloc_list (gfc_alloc *); void gfc_free_namelist (gfc_namelist *); -void gfc_free_omp_namelist (gfc_omp_namelist *, bool, bool); +void gfc_free_omp_namelist (gfc_omp_namelist *, bool, bool, bool); void gfc_free_equiv (gfc_equiv *); void gfc_free_equiv_until (gfc_equiv *, gfc_equiv *); void gfc_free_data (gfc_data *); diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc index 7335d98f222..ba23bcd9692 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -5537,7 +5537,8 @@ gfc_free_namelist (gfc_namelist *name) void gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns, - bool free_align_allocator) + bool free_align_allocator, + bool free_mem_traits_space) { gfc_omp_namelist *n; @@ -5546,10 +5547,14 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns, gfc_free_expr (name->expr); if (free_align_allocator) gfc_free_expr (name->u.align); + else if (free_mem_traits_space) + { } /* name->u.memspace_sym: shall not call gfc_free_symbol here. */ if (free_ns) gfc_free_namespace (name->u2.ns); else if (free_align_allocator) gfc_free_expr (name->u2.allocator); + else if (free_mem_traits_space) + { } /* name->u2.traits_sym: shall not call gfc_free_symbol here. */ else if (name->u2.udr) { if (name->u2.udr->combiner) diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc index 8efc4b3ecfa..05a697da071 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -188,7 +188,8 @@ gfc_free_omp_clauses (gfc_omp_clauses *c) for (i = 0; i < OMP_LIST_NUM; i++) gfc_free_omp_namelist (c->lists[i], i == OMP_LIST_AFFINITY || i == OMP_LIST_DEPEND, - i == OMP_LIST_ALLOCATE); + i == OMP_LIST_ALLOCATE, + i == OMP_LIST_USES_ALLOCATORS); gfc_free_expr_list (c->wait_list); gfc_free_expr_list (c->tile_list); free (CONST_CAST (char *, c->critical_name)); @@ -553,7 +554,7 @@ syntax: gfc_error ("Syntax error in OpenMP variable list at %C"); cleanup: - gfc_free_omp_namelist (head, false, false); + gfc_free_omp_namelist (head, false, false, false); gfc_current_locus = old_loc; return MATCH_ERROR; } @@ -643,7 +644,7 @@ syntax: gfc_error ("Syntax error in OpenMP variable list at %C"); cleanup: - gfc_free_omp_namelist (head, false, false); + gfc_free_omp_namelist (head, false, false, false); gfc_current_locus = old_loc; return MATCH_ERROR; } @@ -752,7 +753,7 @@ syntax: gfc_error ("Syntax error in OpenMP SINK dependence-type list at %C"); cleanup: - gfc_free_omp_namelist (head, false, false); + gfc_free_omp_namelist (head, false, false, false); gfc_current_locus = old_loc; return MATCH_ERROR; } @@ -1091,6 +1092,7 @@ enum omp_mask2 OMP_CLAUSE_ENTER, /* OpenMP 5.2 */ OMP_CLAUSE_DOACROSS, /* OpenMP 5.2 */ OMP_CLAUSE_ASSUMPTIONS, /* OpenMP 5.1. */ + OMP_CLAUSE_USES_ALLOCATORS, /* OpenMP 5.0 */ /* This must come last. */ OMP_MASK2_LAST }; @@ -1502,7 +1504,7 @@ gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc, *head = NULL; gfc_error_now ("!$OMP DECLARE REDUCTION %s not found at %L", buffer, &old_loc); - gfc_free_omp_namelist (n, false, false); + gfc_free_omp_namelist (n, false, false, false); } else for (n = *head; n; n = n->next) @@ -1697,6 +1699,106 @@ omp_verify_merge_absent_contains (gfc_statement st, gfc_omp_assumptions *check, return MATCH_YES; } +/* OpenMP 5.0 + uses_allocators ( allocator-list ) + + allocator: + predefined-allocator + variable ( traits-array ) + + OpenMP 5.2: + uses_allocators ( [modifier-list :] allocator-list ) + + allocator: + variable or predefined-allocator + modifier: + traits ( traits-array ) + memspace ( mem-space-handle ) */ + +static match +gfc_match_omp_clause_uses_allocators (gfc_omp_clauses *c) +{ + gfc_symbol *memspace_sym = NULL; + gfc_symbol *traits_sym = NULL; + gfc_omp_namelist *head = NULL; + gfc_omp_namelist *p, *tail, **list; + int ntraits, nmemspace; + bool has_modifiers; + locus old_loc, cur_loc; + + gfc_gobble_whitespace (); + old_loc = gfc_current_locus; + ntraits = nmemspace = 0; + do + { + cur_loc = gfc_current_locus; + if (gfc_match ("traits ( %S ) ", &traits_sym) == MATCH_YES) + ntraits++; + else if (gfc_match ("memspace ( %S ) ", &memspace_sym) == MATCH_YES) + nmemspace++; + if (ntraits > 1 || nmemspace > 1) + { + gfc_error ("Duplicate %s modifier at %L in USES_ALLOCATORS clause", + ntraits > 1 ? "TRAITS" : "MEMSPACE", &cur_loc); + return MATCH_ERROR; + } + if (gfc_match (", ") == MATCH_YES) + continue; + if (gfc_match (": ") != MATCH_YES) + { + /* Assume no modifier. */ + memspace_sym = traits_sym = NULL; + gfc_current_locus = old_loc; + break; + } + break; + } while (true); + + has_modifiers = traits_sym != NULL || memspace_sym != NULL; + do + { + p = gfc_get_omp_namelist (); + p->where = gfc_current_locus; + if (head == NULL) + head = tail = p; + else + { + tail->next = p; + tail = tail->next; + } + if (gfc_match ("%S ", &p->sym) != MATCH_YES) + goto error; + if (!has_modifiers) + gfc_match ("( %S ) ", &p->u2.traits_sym); + else if (gfc_peek_ascii_char () == '(') + { + gfc_error ("Unexpected %<(%> at %C"); + goto error; + } + else + { + p->u.memspace_sym = memspace_sym; + p->u2.traits_sym = traits_sym; + } + if (gfc_match (", ") == MATCH_YES) + continue; + if (gfc_match (") ") == MATCH_YES) + break; + goto error; + } while (true); + + list = &c->lists[OMP_LIST_USES_ALLOCATORS]; + while (*list) + list = &(*list)->next; + *list = head; + + return MATCH_YES; + +error: + gfc_free_omp_namelist (head, false, false, true); + return MATCH_ERROR; +} + /* Match with duplicate check. Matches 'name'. If expr != NULL, it then matches '(expr)', otherwise, if open_parens is true, @@ -1820,7 +1922,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, if (end_colon && gfc_match (" %e )", &alignment) != MATCH_YES) { - gfc_free_omp_namelist (*head, false, false); + gfc_free_omp_namelist (*head, false, false, false); gfc_current_locus = old_loc; *head = NULL; break; @@ -2763,7 +2865,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, end_colon = true; else if (gfc_match (" )") != MATCH_YES) { - gfc_free_omp_namelist (*head, false, false); + gfc_free_omp_namelist (*head, false, false, false); gfc_current_locus = old_loc; *head = NULL; break; @@ -2774,7 +2876,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, { if (gfc_match (" %e )", &step) != MATCH_YES) { - gfc_free_omp_namelist (*head, false, false); + gfc_free_omp_namelist (*head, false, false, false); gfc_current_locus = old_loc; *head = NULL; goto error; @@ -2871,7 +2973,7 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, } if (has_error) { - gfc_free_omp_namelist (*head, false, false); + gfc_free_omp_namelist (*head, false, false, false); *head = NULL; goto error; } @@ -3561,6 +3663,13 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask, ("use_device_addr (", &c->lists[OMP_LIST_USE_DEVICE_ADDR], false, NULL, NULL, true) == MATCH_YES) continue; + if ((mask & OMP_CLAUSE_USES_ALLOCATORS) + && (gfc_match ("uses_allocators ( ") == MATCH_YES)) + { + if (gfc_match_omp_clause_uses_allocators (c) != MATCH_YES) + goto error; + continue; + } break; case 'v': /* VECTOR_LENGTH must be matched before VECTOR, because the latter @@ -4290,7 +4399,7 @@ cleanup: | OMP_CLAUSE_FIRSTPRIVATE | OMP_CLAUSE_DEFAULTMAP \ | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_IN_REDUCTION \ | OMP_CLAUSE_THREAD_LIMIT | OMP_CLAUSE_ALLOCATE \ - | OMP_CLAUSE_HAS_DEVICE_ADDR) + | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_USES_ALLOCATORS) #define OMP_TARGET_DATA_CLAUSES \ (omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_MAP | OMP_CLAUSE_IF \ | OMP_CLAUSE_USE_DEVICE_PTR | OMP_CLAUSE_USE_DEVICE_ADDR) @@ -4410,7 +4519,7 @@ gfc_match_omp_allocate (void) gfc_error ("Unexpected expression as list item at %L in ALLOCATE " "directive", &n->expr->where); - gfc_free_omp_namelist (vars, false, true); + gfc_free_omp_namelist (vars, false, true, false); goto error; } @@ -4814,14 +4923,14 @@ gfc_match_omp_flush (void) { gfc_error ("List specified together with memory order clause in FLUSH " "directive at %C"); - gfc_free_omp_namelist (list, false, false); + gfc_free_omp_namelist (list, false, false, false); gfc_free_omp_clauses (c); return MATCH_ERROR; } if (gfc_match_omp_eos () != MATCH_YES) { gfc_error ("Unexpected junk after $OMP FLUSH statement at %C"); - gfc_free_omp_namelist (list, false, false); + gfc_free_omp_namelist (list, false, false, false); gfc_free_omp_clauses (c); return MATCH_ERROR; } @@ -7229,7 +7338,8 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, "IN_REDUCTION", "TASK_REDUCTION", "DEVICE_RESIDENT", "LINK", "USE_DEVICE", "CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR", - "NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER" }; + "NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER", + "USES_ALLOCATORS" }; STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM); if (omp_clauses == NULL) @@ -7495,7 +7605,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, " cannot be and need not be mapped", n->sym->name, &n->where); } - else + else if (list != OMP_LIST_USES_ALLOCATORS) gfc_error ("Object %qs is not a variable at %L", n->sym->name, &n->where); } @@ -7721,7 +7831,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, { prev->next = n->next; n->next = NULL; - gfc_free_omp_namelist (n, false, true); + gfc_free_omp_namelist (n, false, true, false); n = prev->next; } continue; @@ -8291,6 +8401,58 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, n = n->next; } break; + case OMP_LIST_USES_ALLOCATORS: + { + if (n != NULL + && n->u.memspace_sym + && (n->u.memspace_sym->attr.flavor != FL_PARAMETER + || n->u.memspace_sym->ts.type != BT_INTEGER + || n->u.memspace_sym->ts.kind != gfc_c_intptr_kind + || n->u.memspace_sym->attr.dimension + || (!startswith (n->u.memspace_sym->name, "omp_") + && !startswith (n->u.memspace_sym->name, "ompx_")) + || !endswith (n->u.memspace_sym->name, "_mem_space"))) + gfc_error ("Memspace %qs at %L in USES_ALLOCATORS must be " + "a predefined memory space", + n->u.memspace_sym->name, &n->where); + for (; n != NULL; n = n->next) + { + if (n->sym->ts.type != BT_INTEGER + || n->sym->ts.kind != gfc_c_intptr_kind + || n->sym->attr.dimension) + gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must " + "be a scalar integer of kind " + "%", n->sym->name, + &n->where); + else if (n->sym->attr.flavor != FL_VARIABLE + && ((!startswith (n->sym->name, "omp_") + && !startswith (n->sym->name, "ompx_")) + || !endswith (n->sym->name, "_mem_alloc"))) + gfc_error ("Allocator %qs at %L in USES_ALLOCATORS must " + "either a variable or a predefined allocator", + n->sym->name, &n->where); + else if ((n->u.memspace_sym || n->u2.traits_sym) + && n->sym->attr.flavor != FL_VARIABLE) + gfc_error ("A memory space or traits array may not be " + "specified for predefined allocator %qs at %L", + n->sym->name, &n->where); + if (n->u2.traits_sym + && (n->u2.traits_sym->attr.flavor != FL_PARAMETER + || !n->u2.traits_sym->attr.dimension + || n->u2.traits_sym->as->rank != 1 + || n->u2.traits_sym->ts.type != BT_DERIVED + || strcmp (n->u2.traits_sym->ts.u.derived->name, + "omp_alloctrait") != 0)) + { + gfc_error ("Traits array %qs in USES_ALLOCATORS %L must " + "be a one-dimensional named constant array of " + "type %", + n->u2.traits_sym->name, &n->where); + break; + } + } + break; + } default: for (; n != NULL; n = n->next) { diff --git a/gcc/fortran/st.cc b/gcc/fortran/st.cc index 55debca8e0b..b6d87c40207 100644 --- a/gcc/fortran/st.cc +++ b/gcc/fortran/st.cc @@ -288,7 +288,7 @@ gfc_free_statement (gfc_code *p) break; case EXEC_OMP_FLUSH: - gfc_free_omp_namelist (p->ext.omp_namelist, false, false); + gfc_free_omp_namelist (p->ext.omp_namelist, false, false, false); break; case EXEC_OMP_BARRIER: diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc index 4aa16fa88da..c88ee3c7656 100644 --- a/gcc/fortran/trans-openmp.cc +++ b/gcc/fortran/trans-openmp.cc @@ -3923,6 +3923,15 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, omp_clauses = gfc_trans_add_clause (node, omp_clauses); } break; + case OMP_LIST_USES_ALLOCATORS: + /* Ignore pre-defined allocators as no special treatment is needed. */ + for (; n != NULL; n = n->next) + if (n->sym->attr.flavor == FL_VARIABLE) + break; + if (n != NULL) + sorry_at (input_location, "% clause with traits " + "and memory spaces"); + break; default: break; } @@ -6581,6 +6590,8 @@ gfc_split_omp_clauses (gfc_code *code, = code->ext.omp_clauses->device; clausesa[GFC_OMP_SPLIT_TARGET].thread_limit = code->ext.omp_clauses->thread_limit; + clausesa[GFC_OMP_SPLIT_TARGET].lists[OMP_LIST_USES_ALLOCATORS] + = code->ext.omp_clauses->lists[OMP_LIST_USES_ALLOCATORS]; for (int i = 0; i < OMP_DEFAULTMAP_CAT_NUM; i++) clausesa[GFC_OMP_SPLIT_TARGET].defaultmap[i] = code->ext.omp_clauses->defaultmap[i]; diff --git a/libgomp/testsuite/libgomp.fortran/uses_allocators_1.f90 b/libgomp/testsuite/libgomp.fortran/uses_allocators_1.f90 new file mode 100644 index 00000000000..66984d98c89 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/uses_allocators_1.f90 @@ -0,0 +1,168 @@ +! { dg-do compile } + +subroutine test + use omp_lib + implicit none + + !$omp target uses_allocators ( omp_default_mem_alloc , omp_large_cap_mem_alloc, & + !$omp& omp_const_mem_alloc,omp_high_bw_mem_alloc, & + !$omp& omp_low_lat_mem_alloc ,omp_cgroup_mem_alloc , & + !$omp& omp_pteam_mem_alloc, omp_thread_mem_alloc ) + block; end block + + !$omp target uses_allocators(omp_default_mem_alloc, omp_high_bw_mem_alloc) & + !$omp& uses_allocators(omp_high_bw_mem_alloc, omp_low_lat_mem_alloc) ! { dg-error "Symbol 'omp_high_bw_mem_alloc' present on multiple clauses" } + block; end block + + !$omp target firstprivate ( omp_default_mem_alloc ) , uses_allocators & + !$omp& (omp_default_mem_alloc , omp_high_bw_mem_alloc ) & + !$omp& map(to: omp_high_bw_mem_alloc) + block; end block +! { dg-error "Object 'omp_default_mem_alloc' is not a variable" "" { target *-*-* } .-4 } +! { dg-error "Symbol 'omp_default_mem_alloc' present on both data and map clauses" "" { target *-*-* } .-5 } +! { dg-error "Symbol 'omp_high_bw_mem_alloc' present on multiple clauses" "" { target *-*-* } .-5 } +! { dg-error "Object 'omp_high_bw_mem_alloc' is not a variable at .1.; parameters cannot be and need not be mapped" "" { target *-*-* } .-5 } +end + +subroutine non_predef + use omp_lib + implicit none + + type(omp_alloctrait), parameter :: trait(0) = [omp_alloctrait :: ] + type(omp_alloctrait), parameter :: trait2(*) & + = [omp_alloctrait (omp_atk_alignment, 16), & + omp_alloctrait (omp_atk_sync_hint, omp_atv_default), & + omp_alloctrait (omp_atk_access, omp_atv_default)] + + integer(kind=omp_allocator_handle_kind) :: a1, a2, a3 + + !$omp target uses_allocators(omp_default_mem_alloc, a1(trait), a2(trait2)) + block; end block + + !$omp target uses_allocators(omp_default_mem_alloc, a1(trait), omp_cgroup_mem_alloc, a1(trait2)) ! { dg-error "Symbol 'a1' present on multiple clauses" } + block; end block + + !$omp target uses_allocators(traits(trait):a1) & + !$omp& uses_allocators ( memspace ( omp_low_lat_mem_space ) , traits ( trait2 ) : a2 , a3) + block; end block + + !$omp target uses_allocators ( traits(trait2) , memspace ( omp_low_lat_mem_space ) : a2 , a3) + block; end block + + !$omp target firstprivate ( a2 ) , & ! { dg-error "Symbol 'a2' present on both data and map clauses" } + !$omp& uses_allocators (a2, a3) & ! { dg-error "Symbol 'a3' present on multiple clauses" } + !$omp& map(to: a3) + block; end block +end subroutine + +subroutine duplicate + use omp_lib + implicit none + type(omp_alloctrait), parameter :: trait1(0) = [omp_alloctrait :: ] + type(omp_alloctrait), parameter :: trait2(0) = [omp_alloctrait :: ] + + !$omp target uses_allocators(traits(trait1), memspace ( omp_low_lat_mem_space ) , traits ( trait2 ) : bar) ! { dg-error "Duplicate TRAITS modifier" } + block; end block + + !$omp target uses_allocators(traits(trait1), memspace ( omp_low_lat_mem_space ) , memspace (omp_large_cap_mem_space) : bar) ! { dg-error "Duplicate MEMSPACE modifier" } + block; end block +end + +subroutine trait_present + use omp_lib + implicit none + + type(omp_alloctrait), parameter :: trait1(0) = [omp_alloctrait :: ] + integer(kind=omp_allocator_handle_kind) :: a1 + + !$omp target uses_allocators(omp_cgroup_mem_alloc(trait1)) ! { dg-error "A memory space or traits array may not be specified for predefined allocator 'omp_cgroup_mem_alloc'" } + block; end block + + !$omp target uses_allocators(traits(trait1) : omp_pteam_mem_alloc) ! { dg-error "A memory space or traits array may not be specified for predefined allocator 'omp_pteam_mem_alloc'" } + block; end block + + !$omp target uses_allocators(memspace(omp_low_lat_mem_space) : omp_thread_mem_alloc) ! { dg-error "A memory space or traits array may not be specified for predefined allocator 'omp_thread_mem_alloc'" } + block; end block + + ! Invalid in OpenMP 5.0 / 5.1, but valid since 5.2 the same as omp_default_mem_space + emptry traits array + !$omp target uses_allocators ( a1 ) + block; end block +end + +subroutine odd_names + use omp_lib + implicit none + + type(omp_alloctrait), parameter :: trait1(0) = [omp_alloctrait :: ] + + ! oddly named allocators: + integer(kind=omp_allocator_handle_kind) :: traits + integer(kind=omp_allocator_handle_kind) :: memspace + + !$omp target uses_allocators ( traits(trait1), memspace(trait1) ) + block; end block + + !$omp target uses_allocators ( traits(trait1), memspace(omp_low_lat_mem_space) : traits) + block; end block + + !$omp target uses_allocators ( memspace(omp_low_lat_mem_space), traits(trait1) : memspace) + block; end block +end + +subroutine more_checks + use omp_lib + implicit none + + integer(kind=kind(omp_low_lat_mem_space)) :: my_memspace + integer(kind=omp_allocator_handle_kind) :: a1, a2(4) + integer(kind=1) :: a3 + + !$omp target uses_allocators ( memspace(my_memspace) : a1) ! { dg-error "Memspace 'my_memspace' at .1. in USES_ALLOCATORS must be a predefined memory space" } + block; end block + + !$omp target uses_allocators ( omp_low_lat_mem_space) ! { dg-error "Allocator 'omp_low_lat_mem_space' at .1. in USES_ALLOCATORS must either a variable or a predefined allocator" } + block; end block + + !$omp target uses_allocators ( memspace (omp_low_lat_mem_alloc) : a1) ! { dg-error "Memspace 'omp_low_lat_mem_alloc' at .1. in USES_ALLOCATORS must be a predefined memory space" } + block; end block + + !$omp target uses_allocators(memspace (omp_low_lat_mem_space) : a1 ) + block; end block + + !$omp target uses_allocators(memspace (omp_low_lat_mem_space) : a2 ) ! { dg-error "Allocator 'a2' at .1. in USES_ALLOCATORS must be a scalar integer of kind 'omp_allocator_handle_kind'" } + block; end block + + !$omp target uses_allocators(memspace (omp_low_lat_mem_space) : a3 ) ! { dg-error "Allocator 'a3' at .1. in USES_ALLOCATORS must be a scalar integer of kind 'omp_allocator_handle_kind'" } + block; end block +end + +subroutine traits_checks + use omp_lib + implicit none + + type(omp_alloctrait), parameter :: trait1 = omp_alloctrait (omp_atk_alignment, 16) + type(omp_alloctrait) :: trait2 + integer(kind=omp_atk_alignment), parameter :: trait3(1) = omp_atk_alignment + integer(kind=omp_allocator_handle_kind) :: a1 + + ! Sensible - but not (yet?) valid - an array constructor: + !$omp target uses_allocators(traits ([omp_alloctrait :: ]) : a1 ) ! { dg-error "Invalid character in name" } + block; end block + !$omp target uses_allocators(a1 ([omp_alloctrait :: ])) ! { dg-error "Invalid character in name" } + block; end block + + !$omp target uses_allocators(traits (trait1) : a1 ) ! { dg-error "Traits array 'trait1' in USES_ALLOCATORS .1. must be a one-dimensional named constant array of type 'omp_alloctrait'" } + block; end block + !$omp target uses_allocators(a1 (trait1)) ! { dg-error "Traits array 'trait1' in USES_ALLOCATORS .1. must be a one-dimensional named constant array of type 'omp_alloctrait'" } + block; end block + + !$omp target uses_allocators(traits (trait2) : a1 ) ! { dg-error "Traits array 'trait2' in USES_ALLOCATORS .1. must be a one-dimensional named constant array of type 'omp_alloctrait'" } + block; end block + !$omp target uses_allocators(a1 (trait2)) ! { dg-error "Traits array 'trait2' in USES_ALLOCATORS .1. must be a one-dimensional named constant array of type 'omp_alloctrait'" } + block; end block + + !$omp target uses_allocators(traits (trait3) : a1 ) ! { dg-error "Traits array 'trait3' in USES_ALLOCATORS .1. must be a one-dimensional named constant array of type 'omp_alloctrait'" } + block; end block + !$omp target uses_allocators(a1 (trait3)) ! { dg-error "Traits array 'trait3' in USES_ALLOCATORS .1. must be a one-dimensional named constant array of type 'omp_alloctrait'" } + block; end block +end diff --git a/libgomp/testsuite/libgomp.fortran/uses_allocators_2.f90 b/libgomp/testsuite/libgomp.fortran/uses_allocators_2.f90 new file mode 100644 index 00000000000..07327969775 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/uses_allocators_2.f90 @@ -0,0 +1,99 @@ +! { dg-do compile } + +! Minimal test for valid code: +! - predefined allocators do not need any special treatment in uses_allocators +! (as 'requires dynamic_allocators' is the default). +! +! - Non-predefined allocators are currently rejected ('sorry)' + +subroutine test + use omp_lib + implicit none + + !$omp target uses_allocators ( omp_default_mem_alloc , omp_large_cap_mem_alloc, & + !$omp& omp_const_mem_alloc,omp_high_bw_mem_alloc, & + !$omp& omp_low_lat_mem_alloc ,omp_cgroup_mem_alloc , & + !$omp& omp_pteam_mem_alloc, omp_thread_mem_alloc ) + block; end block + + !$omp target parallel uses_allocators ( omp_default_mem_alloc , omp_large_cap_mem_alloc, & + !$omp& omp_const_mem_alloc,omp_high_bw_mem_alloc, & + !$omp& omp_low_lat_mem_alloc ,omp_cgroup_mem_alloc , & + !$omp& omp_pteam_mem_alloc, omp_thread_mem_alloc ) + block; end block +end + +subroutine non_predef + use omp_lib + implicit none + + type(omp_alloctrait), parameter :: trait(0) = [omp_alloctrait :: ] + type(omp_alloctrait), parameter :: trait2(*) & + = [omp_alloctrait (omp_atk_alignment, 16), & + omp_alloctrait (omp_atk_sync_hint, omp_atv_default), & + omp_alloctrait (omp_atk_access, omp_atv_default)] + + integer(kind=omp_allocator_handle_kind) :: a1, a2, a3 + + !$omp target uses_allocators(omp_default_mem_alloc, a1(trait), a2(trait2)) ! { dg-message "sorry, unimplemented: 'uses_allocators' clause with traits and memory spaces" } + block; end block + + !$omp target parallel uses_allocators(omp_default_mem_alloc, a1(trait), a2(trait2)) ! { dg-message "sorry, unimplemented: 'uses_allocators' clause with traits and memory spaces" } + block; end block + + + !$omp target uses_allocators(traits(trait):a1) & + !$omp& uses_allocators ( memspace ( omp_low_lat_mem_space ) , traits ( trait2 ) : a2 , a3) ! { dg-message "sorry, unimplemented: 'uses_allocators' clause with traits and memory spaces" } + block; end block + + !$omp target parallel uses_allocators(traits(trait):a1) & + !$omp& uses_allocators ( memspace ( omp_low_lat_mem_space ) , traits ( trait2 ) : a2 , a3) ! { dg-message "sorry, unimplemented: 'uses_allocators' clause with traits and memory spaces" } + block; end block + + !$omp target uses_allocators ( traits(trait2) , memspace ( omp_low_lat_mem_space ) : a2 , a3) ! { dg-message "sorry, unimplemented: 'uses_allocators' clause with traits and memory spaces" } + block; end block +end subroutine + +subroutine trait_present + use omp_lib + implicit none + + type(omp_alloctrait), parameter :: trait1(0) = [omp_alloctrait :: ] + integer(kind=omp_allocator_handle_kind) :: a1 + + ! Invalid in OpenMP 5.0 / 5.1, but valid since 5.2 the same as omp_default_mem_space + emptry traits array + !$omp target uses_allocators ( a1 ) ! { dg-message "sorry, unimplemented: 'uses_allocators' clause with traits and memory spaces" } + block; end block +end + +subroutine odd_names + use omp_lib + implicit none + + type(omp_alloctrait), parameter :: trait1(0) = [omp_alloctrait :: ] + + ! oddly named allocators: + integer(kind=omp_allocator_handle_kind) :: traits + integer(kind=omp_allocator_handle_kind) :: memspace + + !$omp target uses_allocators ( traits(trait1), memspace(trait1) ) ! { dg-message "sorry, unimplemented: 'uses_allocators' clause with traits and memory spaces" } + block; end block + + !$omp target uses_allocators ( traits(trait1), memspace(omp_low_lat_mem_space) : traits) ! { dg-message "sorry, unimplemented: 'uses_allocators' clause with traits and memory spaces" } + block; end block + + !$omp target uses_allocators ( memspace(omp_low_lat_mem_space), traits(trait1) : memspace) ! { dg-message "sorry, unimplemented: 'uses_allocators' clause with traits and memory spaces" } + block; end block +end + +subroutine more_checks + use omp_lib + implicit none + + integer(kind=kind(omp_low_lat_mem_space)) :: my_memspace + integer(kind=omp_allocator_handle_kind) :: a1, a2(4) + integer(kind=1) :: a3 + + !$omp target uses_allocators(memspace (omp_low_lat_mem_space) : a1 ) ! { dg-message "sorry, unimplemented: 'uses_allocators' clause with traits and memory spaces" } + block; end block +end