From: Tobias Burnus <tobias@codesourcery.com>
To: gcc-patches <gcc-patches@gcc.gnu.org>,
fortran <fortran@gcc.gnu.org>, Jakub Jelinek <jakub@redhat.com>
Subject: [Patch] Fortran: Update use_device_ptr for OpenMP 5.1 [PR105318]
Date: Fri, 30 Sep 2022 12:41:19 +0200 [thread overview]
Message-ID: <6005cea4-c89e-0c31-1c61-d322dcf072e7@codesourcery.com> (raw)
[-- Attachment #1.1: Type: text/plain, Size: 913 bytes --]
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
[-- Attachment #2: is_device_ptr-omp51.diff --]
[-- Type: text/x-patch, Size: 14805 bytes --]
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" } }
next reply other threads:[~2022-09-30 10:41 UTC|newest]
Thread overview: 4+ messages / expand[flat|nested] mbox.gz Atom feed top
2022-09-30 10:41 Tobias Burnus [this message]
2022-09-30 10:57 ` Tobias Burnus
2022-09-30 11:04 ` Jakub Jelinek
2022-09-30 11:40 ` Tobias Burnus
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=6005cea4-c89e-0c31-1c61-d322dcf072e7@codesourcery.com \
--to=tobias@codesourcery.com \
--cc=fortran@gcc.gnu.org \
--cc=gcc-patches@gcc.gnu.org \
--cc=jakub@redhat.com \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).