From patchwork Fri Sep 30 10:41:19 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 1684795 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=2620:52:3:1:0:246e:9693:128c; helo=sourceware.org; envelope-from=gcc-patches-bounces+incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Received: from sourceware.org (server2.sourceware.org [IPv6:2620:52:3:1:0:246e:9693:128c]) (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 4Mf6Gv6WkSz1yql for ; Fri, 30 Sep 2022 20:41:43 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id EC184385C400 for ; Fri, 30 Sep 2022 10:41:41 +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 6B5F93858CDB; Fri, 30 Sep 2022 10:41:28 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 6B5F93858CDB 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="5.93,358,1654588800"; d="diff'?scan'208,217";a="86697052" Received: from orw-gwy-01-in.mentorg.com ([192.94.38.165]) by esa1.mentor.iphmx.com with ESMTP; 30 Sep 2022 02:41:26 -0800 IronPort-SDR: ZQeIyZN9qTM+MjzybJ6khVulgRrWAm0eYxCBYXjY3uQJ3WTxkj3pyg325OhtMRtEM1/boeu5+2 1GVZ+yfRDnAysLFOHnvidpnCDAKLnQiKyQjwsz9EfUIt2fFXf6FF4CU9kDRnWFn94AKAwRhOLS g229PQOrPhln716FkanQdyzpLP3p/JjhYk8fZlzPhyWDg5TgNOsARr8Dkf8ctUngHSLF18DPIh B1v59RCE2N1w7JEB44hU8tIMo4UeoE39EqHWW3jrxmFxDc5z14r4e/NVwzPWjjBcgfWzmRzSBy YeU= Message-ID: <6005cea4-c89e-0c31-1c61-d322dcf072e7@codesourcery.com> Date: Fri, 30 Sep 2022 12:41:19 +0200 MIME-Version: 1.0 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:102.0) Gecko/20100101 Thunderbird/102.3.1 Content-Language: en-US To: gcc-patches , fortran , Jakub Jelinek From: Tobias Burnus Subject: [Patch] Fortran: Update use_device_ptr for OpenMP 5.1 [PR105318] X-Originating-IP: [137.202.0.90] X-ClientProxiedBy: svr-ies-mbx-10.mgc.mentorg.com (139.181.222.10) To svr-ies-mbx-12.mgc.mentorg.com (139.181.222.12) X-Spam-Status: No, score=-11.4 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, HTML_MESSAGE, KAM_DMARC_STATUS, SPF_HELO_PASS, SPF_PASS, TXREP 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-Content-Filtered-By: Mailman/MimeDel 2.1.29 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" While has_device_addr has been implemented (in GCC 12), updating use_device_ptr for Fortran was missed. This patch fixes it: Removing the restrictions and mapping to has_device_addr where applicable. For use_device_ptr something similar was done, albeit I think this has no semantic effect. And 'device(omp_initial_device)' printed a warning in Fortran. (BTW: C/C++ silently accepts any negative value.) OK for mainline? Tobias PS: There were several important clarifications/fixes to {has,is,use}_device_{addr,ptr} after the 5.2 release. However, the fixes part mostly affect the user and not the implementation. ----------------- 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 Fortran: Update use_device_ptr for OpenMP 5.1 [PR105318] OpenMP 5.1 added has_device_addr and relaxed the restrictions for use_device_ptr, including processing non-type(c_ptr) arguments as if has_device_addr was used. (There is a semantic difference.) For completeness, the likewise change was done for 'use_device_ptr', where non-type(c_ptr) arguments now use use_device_addr. Finally, a warning for 'device(omp_{initial,invalid}_device)' was silenced on the way as affecting the new testcase. gcc/fortran/ChangeLog: * openmp.cc (resolve_omp_clauses): Update is_device_ptr restrictions for OpenMP 5.1 and map to has_device_addr where applicable; map use_device_ptr to use_device_addr where applicable. Silence integer-range warning for device(omp_{initial,invalid}_device). libgomp/ChangeLog: * testsuite/libgomp.fortran/is_device_ptr-2.f90: New test. gcc/testsuite/ChangeLog: * gfortran.dg/gomp/is_device_ptr-1.f90: Remove dg-error. * gfortran.dg/gomp/is_device_ptr-2.f90: Likewise. * gfortran.dg/gomp/is_device_ptr-3.f90: Update tree-scan-dump. gcc/fortran/openmp.cc | 81 +++++++--- gcc/testsuite/gfortran.dg/gomp/is_device_ptr-1.f90 | 9 +- gcc/testsuite/gfortran.dg/gomp/is_device_ptr-2.f90 | 2 +- gcc/testsuite/gfortran.dg/gomp/is_device_ptr-3.f90 | 3 +- .../testsuite/libgomp.fortran/is_device_ptr-2.f90 | 167 +++++++++++++++++++++ 5 files changed, 235 insertions(+), 27 deletions(-) diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc index 457e983663b..313d4e2de1b 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -6511,7 +6511,7 @@ static void resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, gfc_namespace *ns, bool openacc = false) { - gfc_omp_namelist *n; + gfc_omp_namelist *n, *last; gfc_expr_list *el; int list; int ifc; @@ -7369,30 +7369,58 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, } break; case OMP_LIST_IS_DEVICE_PTR: - for (n = omp_clauses->lists[list]; n != NULL; n = n->next) + last = NULL; + for (n = omp_clauses->lists[list]; n != NULL; ) { - if (!n->sym->attr.dummy) - gfc_error ("Non-dummy object %qs in %s clause at %L", - n->sym->name, name, &n->where); - if (n->sym->attr.allocatable - || (n->sym->ts.type == BT_CLASS - && CLASS_DATA (n->sym)->attr.allocatable)) - gfc_error ("ALLOCATABLE object %qs in %s clause at %L", - n->sym->name, name, &n->where); - if (n->sym->attr.pointer - || (n->sym->ts.type == BT_CLASS - && CLASS_DATA (n->sym)->attr.pointer)) - gfc_error ("POINTER object %qs in %s clause at %L", - n->sym->name, name, &n->where); - if (n->sym->attr.value) - gfc_error ("VALUE object %qs in %s clause at %L", - n->sym->name, name, &n->where); + if (n->sym->ts.type == BT_DERIVED + && n->sym->ts.u.derived->ts.is_iso_c + && code->op != EXEC_OMP_TARGET) + /* Non-TARGET (i.e. DISPATCH) requires a C_PTR. */ + gfc_error ("List item %qs in %s clause at %L must be of " + "TYPE(C_PTR)", n->sym->name, name, &n->where); + else if (n->sym->ts.type != BT_DERIVED + || !n->sym->ts.u.derived->ts.is_iso_c) + { + /* For TARGET, non-C_PTR are deprecated and handled as + has_device_addr. */ + gfc_omp_namelist *n2 = n; + n = n->next; + if (last) + last->next = n; + else + omp_clauses->lists[list] = n; + n2->next = omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR]; + omp_clauses->lists[OMP_LIST_HAS_DEVICE_ADDR] = n2; + continue; + } + last = n; + n = n->next; } break; case OMP_LIST_HAS_DEVICE_ADDR: - case OMP_LIST_USE_DEVICE_PTR: case OMP_LIST_USE_DEVICE_ADDR: - /* FIXME: Handle OMP_LIST_USE_DEVICE_PTR. */ + break; + case OMP_LIST_USE_DEVICE_PTR: + /* Non-C_PTR are deprecated and handled as use_device_ADDR. */ + last = NULL; + for (n = omp_clauses->lists[list]; n != NULL; ) + { + gfc_omp_namelist *n2 = n; + if (n->sym->ts.type != BT_DERIVED + || !n->sym->ts.u.derived->ts.is_iso_c) + { + n = n->next; + if (last) + last->next = n; + else + omp_clauses->lists[list] = n; + n2->next = omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR]; + omp_clauses->lists[OMP_LIST_USE_DEVICE_ADDR] = n2; + continue; + } + last = n; + n = n->next; + } break; default: for (; n != NULL; n = n->next) @@ -7758,7 +7786,18 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, &omp_clauses->num_teams_lower->where, &omp_clauses->num_teams_upper->where); if (omp_clauses->device) - resolve_nonnegative_int_expr (omp_clauses->device, "DEVICE"); + { + resolve_scalar_int_expr (omp_clauses->device, "DEVICE"); + /* omp_initial_device == 1, omp_invalid_device = -4 (in GCC). */ + if (omp_clauses->device->expr_type == EXPR_CONSTANT + && omp_clauses->device->ts.type == BT_INTEGER + && mpz_cmp_si (omp_clauses->device->value.integer, -1) < 0 + && mpz_cmp_si (omp_clauses->device->value.integer, -4) != 0) + gfc_warning (0, + "INTEGER expression of DEVICE clause at %L must be non-" + "negative or omp_initial_device or omp_invalid_device", + &omp_clauses->device->where); + } if (omp_clauses->filter) resolve_nonnegative_int_expr (omp_clauses->filter, "FILTER"); if (omp_clauses->hint) diff --git a/gcc/testsuite/gfortran.dg/gomp/is_device_ptr-1.f90 b/gcc/testsuite/gfortran.dg/gomp/is_device_ptr-1.f90 index 0eeca0ee23a..e96ce02df2e 100644 --- a/gcc/testsuite/gfortran.dg/gomp/is_device_ptr-1.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/is_device_ptr-1.f90 @@ -1,4 +1,5 @@ ! { dg-do compile } +! First subroutine test(b,c,d) implicit none integer, value, target :: b @@ -7,16 +8,16 @@ subroutine test(b,c,d) integer, target :: a(5) - !$omp target is_device_ptr(a) ! { dg-error "Non-dummy object .a. in IS_DEVICE_PTR clause" } + !$omp target is_device_ptr(a) ! Valid since OpenMP 5.1 !$omp end target - !$omp target is_device_ptr(b) ! { dg-error "VALUE object .b. in IS_DEVICE_PTR clause" } + !$omp target is_device_ptr(b) ! Valid since OpenMP 5.1 !$omp end target - !$omp target is_device_ptr(c) ! { dg-error "POINTER object .c. in IS_DEVICE_PTR clause" } + !$omp target is_device_ptr(c) ! Valid since OpenMP 5.1 !$omp end target - !$omp target is_device_ptr(d) ! { dg-error "ALLOCATABLE object .d. in IS_DEVICE_PTR clause" } + !$omp target is_device_ptr(d) ! Valid since OpenMP 5.1 !$omp end target !$omp target data map(a) use_device_addr(a) ! Should be okay diff --git a/gcc/testsuite/gfortran.dg/gomp/is_device_ptr-2.f90 b/gcc/testsuite/gfortran.dg/gomp/is_device_ptr-2.f90 index 7adc6f6e8e1..0762e5755e1 100644 --- a/gcc/testsuite/gfortran.dg/gomp/is_device_ptr-2.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/is_device_ptr-2.f90 @@ -8,7 +8,7 @@ subroutine abc(cc) !$omp target enter data map(to: cc, dd) !$omp target data use_device_addr(cc) use_device_ptr(dd) - !$omp target is_device_ptr(cc, dd) ! { dg-error "Non-dummy object 'dd' in IS_DEVICE_PTR clause at" } + !$omp target is_device_ptr(cc, dd) ! Valid since OpenMP 5.1 if (cc /= 131 .or. dd /= 484) stop 1 cc = 44 dd = 45 diff --git a/gcc/testsuite/gfortran.dg/gomp/is_device_ptr-3.f90 b/gcc/testsuite/gfortran.dg/gomp/is_device_ptr-3.f90 index c3de7726e88..7b5b27baa72 100644 --- a/gcc/testsuite/gfortran.dg/gomp/is_device_ptr-3.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/is_device_ptr-3.f90 @@ -23,5 +23,6 @@ contains end program main -! { dg-final { scan-tree-dump "is_device_ptr\\(a\\)" "gimple" } } +! { dg-final { scan-tree-dump "has_device_addr\\(a\\)" "gimple" } } +! { dg-final { scan-tree-dump-not "has_device_addr\\(b\\)" "gimple" } } ! { dg-final { scan-tree-dump-not "is_device_ptr\\(b\\)" "gimple" } } diff --git a/libgomp/testsuite/libgomp.fortran/is_device_ptr-2.f90 b/libgomp/testsuite/libgomp.fortran/is_device_ptr-2.f90 new file mode 100644 index 00000000000..5ecdd420533 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/is_device_ptr-2.f90 @@ -0,0 +1,167 @@ +! { dg-do compile } +! { dg-additional-options "-fdump-tree-original" } +! +! Since OpenMP 5.1, non-TYPE(c_ptr) arguments to is_device_ptr +! map to has_device_ptr - check this! +! +! PR fortran/105318 +! +module m + use iso_c_binding, only: c_ptr, c_loc, c_f_pointer, c_associated + implicit none (type, external) +contains + subroutine one (as, ar, asp, arp, asa, ara, cptr_a) + integer, target :: AS, AR(5) + integer, pointer :: ASP, ARP(:) + integer, allocatable :: ASA, ARA(:) + + type(c_ptr) :: cptr_a + + !$omp target is_device_ptr(as, ar, asp, arp, asa, ara, cptr_a) + if (.not. c_associated (cptr_a, c_loc(as))) stop 18 + if (as /= 5) stop 19 + if (any (ar /= [1,2,3,4,5])) stop 20 + if (asp /= 9) stop 21 + if (any (arp /= [2,4,6])) stop 22 + !$omp end target + end + + subroutine two (cptr_v) + type(c_ptr), value :: cptr_v + integer, pointer :: xx + + xx => null() + !$omp target is_device_ptr(cptr_v) + if (.not. c_associated (cptr_v)) stop 23 + call c_f_pointer (cptr_v, xx) + if (xx /= 5) stop 24 + xx => null() + !$omp end target + end + + subroutine three (os, or, osp, orp, osa, ora, cptr_o) + integer, optional, target :: OS, OR(5) + integer, optional, pointer :: OSP, ORP(:) + integer, optional, allocatable :: OSA, ORA(:) + + type(c_ptr) :: cptr_o + + !$omp target is_device_ptr(os, or, osp, orp, osa, ora, cptr_o) + if (.not. c_associated (cptr_o, c_loc(os))) stop 25 + if (os /= 5) stop 26 + if (any (or /= [1,2,3,4,5])) stop 27 + if (osp /= 9) stop 28 + if (any (orp /= [2,4,6])) stop 29 + !$omp end target + end + + subroutine four(NVS, NVSO) + use omp_lib, only: omp_initial_device, omp_invalid_device + integer, value :: NVS + integer, optional, value :: NVSO + integer :: NS, NR(5) + logical, volatile :: false_ + + false_ = .false. + + !$omp target is_device_ptr (NS, NR, NVS, NVSO) device(omp_initial_device) + NVS = 5 + NVSO = 5 + NS = 5 + NR(1) = 7 + !$omp end target + + if (false_) then + !$omp target device(omp_invalid_device) ! value = -4 + !$omp end target + + !$omp target device(-2) ! { dg-warning "INTEGER expression of DEVICE clause at .1. must be non-negative or omp_initial_device or omp_invalid_device" } + !$omp end target + !$omp target device(-3) ! { dg-warning "INTEGER expression of DEVICE clause at .1. must be non-negative or omp_initial_device or omp_invalid_device" } + !$omp end target + !$omp target device(-5) ! { dg-warning "INTEGER expression of DEVICE clause at .1. must be non-negative or omp_initial_device or omp_invalid_device" } + !$omp end target + end if + end subroutine + +end module m + +program main + use iso_c_binding, only: c_ptr, c_loc, c_f_pointer, c_associated + use m + implicit none (type, external) + + integer, target :: IS, IR(5) + integer, pointer :: ISP, IRP(:) + integer, allocatable :: ISA, IRA(:) + integer :: xxx, xxxx + + type(c_ptr) :: cptr_i + + is = 5 + ir = [1,2,3,4,5] + allocate(ISP, source=9) + allocate(IRP, source=[2,4,6]) + + !$omp target data map(is, ir, isp, irp, isa, ira) & + !$omp& use_device_ptr(is, ir, isp, irp, isa, ira) + + cptr_i = c_loc(is) + !$omp target is_device_ptr(is, ir, isp, irp, isa, ira, cptr_i) + if (.not. c_associated (cptr_i, c_loc(is))) stop 30 + if (is /= 5) stop 31 + if (any (ir /= [1,2,3,4,5])) stop 32 + if (isp /= 9) stop 33 + if (any (irp /= [2,4,6])) stop 34 + !$omp end target + + call one (is, ir, isp, irp, isa, ira, cptr_i) + call two (cptr_i) + call three (is, ir, isp, irp, isa, ira, cptr_i) + + !$omp end target data + + call four(xxx, xxxx) +end + +! { dg-final { scan-tree-dump-not "use_device_ptr" "original" } } +! { dg-final { scan-tree-dump "use_device_addr\\(ira\\)" "original" } } +! { dg-final { scan-tree-dump "use_device_addr\\(isa\\)" "original" } } +! { dg-final { scan-tree-dump "use_device_addr\\(irp\\)" "original" } } +! { dg-final { scan-tree-dump "use_device_addr\\(isp\\)" "original" } } +! { dg-final { scan-tree-dump "use_device_addr\\(ir\\)" "original" } } +! { dg-final { scan-tree-dump "use_device_addr\\(is\\)" "original" } } + +! { dg-final { scan-tree-dump-not "use_device_addr\\(cptr" "original" } } +! { dg-final { scan-tree-dump-not "use_device_ptr\\(o" "original" } } +! { dg-final { scan-tree-dump-not "use_device_ptr\\(a" "original" } } +! { dg-final { scan-tree-dump-not "use_device_ptr\\(i" "original" } } + +! { dg-final { scan-tree-dump "is_device_ptr\\(cptr_o\\)" "original" } } +! { dg-final { scan-tree-dump "has_device_addr\\(ora\\)" "original" } } +! { dg-final { scan-tree-dump "has_device_addr\\(osa\\)" "original" } } +! { dg-final { scan-tree-dump "has_device_addr\\(orp\\)" "original" } } +! { dg-final { scan-tree-dump "has_device_addr\\(osp\\)" "original" } } +! { dg-final { scan-tree-dump "has_device_addr\\(or\\)" "original" } } +! { dg-final { scan-tree-dump "has_device_addr\\(os\\)" "original" } } +! { dg-final { scan-tree-dump "is_device_ptr\\(cptr_v\\)" "original" } } +! { dg-final { scan-tree-dump "is_device_ptr\\(cptr_a\\)" "original" } } +! { dg-final { scan-tree-dump "has_device_addr\\(ara\\)" "original" } } +! { dg-final { scan-tree-dump "has_device_addr\\(asa\\)" "original" } } +! { dg-final { scan-tree-dump "has_device_addr\\(arp\\)" "original" } } +! { dg-final { scan-tree-dump "has_device_addr\\(asp\\)" "original" } } +! { dg-final { scan-tree-dump "has_device_addr\\(ar\\)" "original" } } +! { dg-final { scan-tree-dump "has_device_addr\\(as\\)" "original" } } +! { dg-final { scan-tree-dump "use_device_addr\\(is\\)" "original" } } +! { dg-final { scan-tree-dump "use_device_addr\\(ir\\)" "original" } } +! { dg-final { scan-tree-dump "use_device_addr\\(isp\\)" "original" } } +! { dg-final { scan-tree-dump "use_device_addr\\(irp\\)" "original" } } +! { dg-final { scan-tree-dump "use_device_addr\\(isa\\)" "original" } } +! { dg-final { scan-tree-dump "use_device_addr\\(ira\\)" "original" } } +! { dg-final { scan-tree-dump "is_device_ptr\\(cptr_i\\)" "original" } } +! { dg-final { scan-tree-dump "has_device_addr\\(ira\\)" "original" } } +! { dg-final { scan-tree-dump "has_device_addr\\(isa\\)" "original" } } +! { dg-final { scan-tree-dump "has_device_addr\\(irp\\)" "original" } } +! { dg-final { scan-tree-dump "has_device_addr\\(isp\\)" "original" } } +! { dg-final { scan-tree-dump "has_device_addr\\(ir\\)" "original" } } +! { dg-final { scan-tree-dump "has_device_addr\\(is\\)" "original" } }