public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r13-2980] Fortran: Update use_device_ptr for OpenMP 5.1 [PR105318]
@ 2022-09-30 11:37 Tobias Burnus
  0 siblings, 0 replies; only message in thread
From: Tobias Burnus @ 2022-09-30 11:37 UTC (permalink / raw)
  To: gcc-cvs

https://gcc.gnu.org/g:10a116104969b3ecc9ea4abdd5436c66fd78d537

commit r13-2980-g10a116104969b3ecc9ea4abdd5436c66fd78d537
Author: Tobias Burnus <tobias@codesourcery.com>
Date:   Fri Sep 30 13:27:32 2022 +0200

    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.
    
            PR fortran/105318
    
    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.

Diff:
---
 gcc/fortran/openmp.cc                              |  70 ++++++---
 gcc/testsuite/gfortran.dg/gomp/is_device_ptr-1.f90 |   8 +-
 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  | 159 +++++++++++++++++++++
 5 files changed, 215 insertions(+), 27 deletions(-)

diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc
index 457e983663b..ce719bd5d92 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,7 @@ 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");
   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..1d3a0d8cd33 100644
--- a/gcc/testsuite/gfortran.dg/gomp/is_device_ptr-1.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/is_device_ptr-1.f90
@@ -7,16 +7,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..5b7fab075ae
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/is_device_ptr-2.f90
@@ -0,0 +1,159 @@
+! { 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)
+      !$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" } }

^ permalink raw reply	[flat|nested] only message in thread

only message in thread, other threads:[~2022-09-30 11:37 UTC | newest]

Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-09-30 11:37 [gcc r13-2980] Fortran: Update use_device_ptr for OpenMP 5.1 [PR105318] Tobias Burnus

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).