Fortran polymorphic class-type support for OpenACC

gcc/fortran/
	* openmp.c (resolve_oacc_data_clauses): Don't disallow allocatable
	polymorphic types for OpenACC.
	* trans-openmp.c (gfc_trans_omp_clauses): Support polymorphic class
	types.

	libgomp/
	* testsuite/libgomp.oacc-fortran/class-ptr-param.f95: New test.
	* testsuite/libgomp.oacc-fortran/classtypes-1.f95: New test.
	* testsuite/libgomp.oacc-fortran/classtypes-2.f95: New test.

From-SVN: r279631

gcc/fortran/ChangeLog

@@ -1,3 +1,10 @@
+2019-12-19  Julian Brown  <julian@codesourcery.com>
+
+	* openmp.c (resolve_oacc_data_clauses): Don't disallow allocatable
+	polymorphic types for OpenACC.
+	* trans-openmp.c (gfc_trans_omp_clauses): Support polymorphic class
+	types.
+
 2019-12-19  Julian Brown  <julian@codesourcery.com>
 
 	* gfortran.h (gfc_omp_map_op): Add OMP_MAP_ATTACH, OMP_MAP_DETACH.

gcc/fortran/openmp.c

@@ -3929,12 +3929,6 @@ check_array_not_assumed (gfc_symbol *sym, locus loc, const char *name)
 static void
 resolve_oacc_data_clauses (gfc_symbol *sym, locus loc, const char *name)
 {
-  if ((sym->ts.type == BT_ASSUMED && sym->attr.allocatable)
-      || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
-	  && CLASS_DATA (sym)->attr.allocatable))
-    gfc_error ("ALLOCATABLE object %qs of polymorphic type "
-	       "in %s clause at %L", sym->name, name, &loc);
-  check_symbol_not_pointer (sym, loc, name);
   check_array_not_assumed (sym, loc, name);
 }
 

gcc/fortran/trans-openmp.c

@@ -2471,7 +2471,35 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
 		  tree present = (gfc_omp_is_optional_argument (decl)
 				  ? gfc_omp_check_optional_argument (decl, true)
 				  : NULL_TREE);
-		  if (POINTER_TYPE_P (TREE_TYPE (decl))
+		  if (n->sym->ts.type == BT_CLASS)
+		    {
+		      tree type = TREE_TYPE (decl);
+		      if (n->sym->attr.optional)
+			sorry ("optional class parameter");
+		      if (POINTER_TYPE_P (type))
+			{
+			  node4 = build_omp_clause (input_location,
+						    OMP_CLAUSE_MAP);
+			  OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER);
+			  OMP_CLAUSE_DECL (node4) = decl;
+			  OMP_CLAUSE_SIZE (node4) = size_int (0);
+			  decl = build_fold_indirect_ref (decl);
+			}
+		      tree ptr = gfc_class_data_get (decl);
+		      ptr = build_fold_indirect_ref (ptr);
+		      OMP_CLAUSE_DECL (node) = ptr;
+		      OMP_CLAUSE_SIZE (node) = gfc_class_vtab_size_get (decl);
+		      node2 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
+		      OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_TO_PSET);
+		      OMP_CLAUSE_DECL (node2) = decl;
+		      OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
+		      node3 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
+		      OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_ATTACH_DETACH);
+		      OMP_CLAUSE_DECL (node3) = gfc_class_data_get (decl);
+		      OMP_CLAUSE_SIZE (node3) = size_int (0);
+		      goto finalize_map_clause;
+		    }
+		  else if (POINTER_TYPE_P (TREE_TYPE (decl))
 			   && (gfc_omp_privatize_by_reference (decl)
 			       || GFC_DECL_GET_SCALAR_POINTER (decl)
 			       || GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
@@ -2645,11 +2673,15 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
 
 		  symbol_attribute sym_attr;
 
+		  if (lastcomp->u.c.component->ts.type == BT_CLASS)
+		    sym_attr = CLASS_DATA (lastcomp->u.c.component)->attr;
+		  else
 		    sym_attr = lastcomp->u.c.component->attr;
 
 		  gfc_init_se (&se, NULL);
 
 		  if (!sym_attr.dimension
+		      && lastcomp->u.c.component->ts.type != BT_CLASS
 		      && lastcomp->u.c.component->ts.type != BT_DERIVED)
 		    {
 		      /* Last component is a scalar.  */
@@ -2679,13 +2711,24 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
 
 		  tree inner = se.expr;
 
-		  /* Last component is a derived type.  */
+		  /* Last component is a derived type or class pointer.  */
-		  if (lastcomp->u.c.component->ts.type == BT_DERIVED)
+		  if (lastcomp->u.c.component->ts.type == BT_DERIVED
+		      || lastcomp->u.c.component->ts.type == BT_CLASS)
 		    {
 		      if (sym_attr.allocatable || sym_attr.pointer)
 			{
-			  tree data = inner;
+			  tree data, size;
-			  tree size = TYPE_SIZE_UNIT (TREE_TYPE (inner));
+
+			  if (lastcomp->u.c.component->ts.type == BT_CLASS)
+			    {
+			      data = gfc_class_data_get (inner);
+			      size = gfc_class_vtab_size_get (inner);
+			    }
+			  else  /* BT_DERIVED.  */
+			    {
+			      data = inner;
+			      size = TYPE_SIZE_UNIT (TREE_TYPE (inner));
+			    }
 
 			  OMP_CLAUSE_DECL (node)
 			    = build_fold_indirect_ref (data);

libgomp/ChangeLog

@@ -1,3 +1,9 @@
+2019-12-19  Julian Brown  <julian@codesourcery.com>
+
+	* testsuite/libgomp.oacc-fortran/class-ptr-param.f95: New test.
+	* testsuite/libgomp.oacc-fortran/classtypes-1.f95: New test.
+	* testsuite/libgomp.oacc-fortran/classtypes-2.f95: New test.
+
 2019-12-19  Julian Brown  <julian@codesourcery.com>
 	    Cesar Philippidis  <cesar@codesourcery.com>
 

libgomp/testsuite/libgomp.oacc-fortran/class-ptr-param.f95

@@ -0,0 +1,34 @@
+! { dg-do run }
+
+module typemod
+
+type mytype
+  integer :: a
+end type mytype
+
+contains
+
+subroutine mysub(c)
+  implicit none
+
+  class(mytype), allocatable :: c
+
+!$acc parallel copy(c)
+  c%a = 5
+!$acc end parallel
+end subroutine mysub
+
+end module typemod
+
+program main
+  use typemod
+  implicit none
+
+  class(mytype), allocatable :: myvar
+  allocate(mytype :: myvar)
+
+  myvar%a = 0
+  call mysub(myvar)
+
+  if (myvar%a .ne. 5) stop 1
+end program main

libgomp/testsuite/libgomp.oacc-fortran/classtypes-1.f95

@@ -0,0 +1,48 @@
+! { dg-do run }
+
+module typemod
+
+type :: typeimpl
+  real, pointer :: p(:) => null()
+end type typeimpl
+
+type :: basictype
+  class(typeimpl), pointer :: p => null()
+end type basictype
+
+type, extends(basictype) :: regulartype
+  character :: void
+end type regulartype
+
+end module typemod
+
+program main
+  use typemod
+  implicit none
+  type(regulartype), pointer :: myvar
+  integer :: i
+  real :: j, k
+
+  allocate(myvar)
+  allocate(myvar%p)
+  allocate(myvar%p%p(1:100))
+
+  do i=1,100
+    myvar%p%p(i) = -1.0
+  end do
+
+!$acc enter data copyin(myvar, myvar%p) create(myvar%p%p)
+
+!$acc parallel loop present(myvar%p%p)
+  do i=1,100
+    myvar%p%p(i) = i * 2
+  end do
+!$acc end parallel loop
+
+!$acc exit data copyout(myvar%p%p) delete(myvar, myvar%p)
+
+  do i=1,100
+    if (myvar%p%p(i) .ne. i * 2) stop 1
+  end do
+
+end program main

libgomp/testsuite/libgomp.oacc-fortran/classtypes-2.f95

@@ -0,0 +1,106 @@
+! { dg-do run }
+
+module wrapper_mod
+
+type compute
+  integer, allocatable :: block(:,:)
+contains
+  procedure :: initialize
+end type compute
+
+type, extends(compute) :: cpu_compute
+  integer :: blocksize
+contains
+  procedure :: setblocksize
+end type cpu_compute
+
+type, extends(compute) :: gpu_compute
+  integer :: numgangs
+  integer :: numworkers
+  integer :: vectorsize
+  integer, allocatable :: gpu_block(:,:)
+contains
+  procedure :: setdims
+end type gpu_compute
+
+contains
+
+subroutine initialize(c, length, width)
+  implicit none
+  class(compute) :: c
+  integer :: length
+  integer :: width
+  integer :: i
+  integer :: j
+
+  allocate (c%block(length, width))
+
+  do i=1,length
+    do j=1, width
+      c%block(i,j) = i + j
+    end do
+  end do
+end subroutine initialize
+
+subroutine setdims(c, g, w, v)
+  implicit none
+  class(gpu_compute) :: c
+  integer :: g
+  integer :: w
+  integer :: v
+  c%numgangs = g
+  c%numworkers = w
+  c%vectorsize = v
+end subroutine setdims
+
+subroutine setblocksize(c, bs)
+  implicit none
+  class(cpu_compute) :: c
+  integer :: bs
+  c%blocksize = bs
+end subroutine setblocksize
+
+end module wrapper_mod
+
+program main
+  use wrapper_mod
+  implicit none
+  class(compute), allocatable, target :: mycomp
+  integer :: i, j
+
+  allocate(gpu_compute::mycomp)
+
+  call mycomp%initialize(1024,1024)
+
+  !$acc enter data copyin(mycomp)
+
+  select type (mycomp)
+  type is (cpu_compute)
+    call mycomp%setblocksize(32)
+  type is (gpu_compute)
+    call mycomp%setdims(32,32,32)
+    allocate(mycomp%gpu_block(1024,1024))
+    !$acc update device(mycomp)
+    !$acc parallel copyin(mycomp%block) copyout(mycomp%gpu_block)
+    !$acc loop gang worker vector collapse(2)
+    do i=1,1024
+      do j=1,1024
+        mycomp%gpu_block(i,j) = mycomp%block(i,j) + 1
+      end do
+    end do
+    !$acc end parallel
+  end select
+
+  !$acc exit data copyout(mycomp)
+
+  select type (g => mycomp)
+  type is (gpu_compute)
+  do i = 1, 1024
+    do j = 1, 1024
+      if (g%gpu_block(i,j) .ne. i + j + 1) stop 1
+    end do
+  end do
+  end select
+
+  deallocate(mycomp)
+end program main