This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[PATCH] Fortran polymorphic class-type support for OpenACC
- From: Julian Brown <julian at codesourcery dot com>
- To: <gcc-patches at gcc dot gnu dot org>
- Cc: Jakub Jelinek <jakub at redhat dot com>, Thomas Schwinge <thomas at codesourcery dot com>
- Date: Tue, 8 Oct 2019 06:37:16 -0700
- Subject: [PATCH] Fortran polymorphic class-type support for OpenACC
- Ironport-sdr: tee4xYT18Nrxtx/2n26QOPjWa/LPcCRb4HfLfF4KCqVKVg91x//uUn3v72o2E+ZZjmYTSKcE8M k7QmyHcp9VcepggqNv6gxg0OL5mNuwVzsSVx2gt0hYOHJw9I4tu2UfiS3XP4k86oyIvSAlCpug 6vjSiBQ2lxVL4rVRrPuD/l0kY3NmRnM+MUUlzrAgvhJvf2XPkOZnUHqKp9WZ8s7D4+7Bj5v75B zpZW1q0b4p8bPxDIhDmH0tatuVVmNqxg0W3GNJNM3ysv6LTbIyTz4cH34Rz6QJkK9YFJm36qV8 2SQ=
- Ironport-sdr: FODgCtf9tojaKdXpEgYfcSFfry1J5kRBab1vnbdWQ+LPAHSjp6MOCMES/I3UG7RpzXuYCYhBgN loVnEq6J4kR7LAsK5xQbfot2/ZFqY7T5KrPbDkF9BqzNVg/GPPfJlnhFL0TpGLJfjhB9OMlQi+ lmhLNr8ytX44Qlg37CBiEKd7dIu3qF2CYjS0oPcBK+G/pflBoDDoz3KT59bGwocE6NtV6Nm+rL 0a2SvG8qMwT9uYR43hXMiBFtiX6a9bQV1Xq1IInOxewQyp7jtDvp4lcZJHh6XHRS3N6+tZJHjU MHQ=
This patch provides basic support for Fortran (2003) polymorphic class
pointers. Such pointers have a descriptor that is somewhat like an array
descriptor, so I re-used the GOMP_MAP_TO_PSET mapping to transfer such
class descriptors from the host to the target. That seems to work well,
though I don't know at present how to exhaustively test sophisticated
uses of polymorphic types.
This patch builds on top of the manual deep copy patch posted here:
https://gcc.gnu.org/ml/gcc-patches/2019-10/msg00444.html
Tested with offloading to nvptx (and bootstrapped on x86_64). The new
tests pass, and a much larger test program using polymorphic types also
works with this patch.
During development of this patch (and the derived-type parts of the
previously-posted manual deep copy patch) I made a few notes on the
various pointer mapping kinds used by the OpenACC support (and lesserly
the OpenMP support) in GCC/libgomp. I've now put those up here:
https://gcc.gnu.org/wiki/LibgompPointerMappingKinds
An example of how a Fortran class-pointer type is mapped with OpenACC
is given there, under GOMP_MAP_TO_PSET.
OK for trunk?
Thanks,
Julian
ChangeLog
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.
---
gcc/fortran/openmp.c | 6 -
gcc/fortran/trans-openmp.c | 69 +++++++++---
.../libgomp.oacc-fortran/class-ptr-param.f95 | 34 ++++++
.../libgomp.oacc-fortran/classtypes-1.f95 | 48 ++++++++
.../libgomp.oacc-fortran/classtypes-2.f95 | 106 ++++++++++++++++++
5 files changed, 244 insertions(+), 19 deletions(-)
create mode 100644 libgomp/testsuite/libgomp.oacc-fortran/class-ptr-param.f95
create mode 100644 libgomp/testsuite/libgomp.oacc-fortran/classtypes-1.f95
create mode 100644 libgomp/testsuite/libgomp.oacc-fortran/classtypes-2.f95
diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c
index f08f77ce940..cf7612c6750 100644
--- a/gcc/fortran/openmp.c
+++ b/gcc/fortran/openmp.c
@@ -3883,12 +3883,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);
}
diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index 775548fe9af..892bb1752b9 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -2244,14 +2244,42 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
TREE_ADDRESSABLE (decl) = 1;
if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL)
{
- 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)
- || GFC_DECL_CRAY_POINTEE (decl)
- || GFC_DESCRIPTOR_TYPE_P
- (TREE_TYPE (TREE_TYPE (decl)))
- || n->sym->ts.type == BT_DERIVED))
+ 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)
+ || GFC_DECL_CRAY_POINTEE (decl)
+ || GFC_DESCRIPTOR_TYPE_P
+ (TREE_TYPE (TREE_TYPE (decl)))
+ || n->sym->ts.type == BT_DERIVED))
{
tree orig_decl = decl;
node4 = build_omp_clause (input_location,
@@ -2356,11 +2384,15 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
symbol_attribute sym_attr;
- sym_attr = lastcomp->u.c.component->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. */
@@ -2392,13 +2424,24 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
tree inner = se.expr;
- /* Last component is a derived type. */
- if (lastcomp->u.c.component->ts.type == BT_DERIVED)
+ /* Last component is a derived type or class pointer. */
+ 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 size = TYPE_SIZE_UNIT (TREE_TYPE (inner));
+ tree data, size;
+
+ 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);
diff --git a/libgomp/testsuite/libgomp.oacc-fortran/class-ptr-param.f95 b/libgomp/testsuite/libgomp.oacc-fortran/class-ptr-param.f95
new file mode 100644
index 00000000000..80147337c9d
--- /dev/null
+++ b/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
diff --git a/libgomp/testsuite/libgomp.oacc-fortran/classtypes-1.f95 b/libgomp/testsuite/libgomp.oacc-fortran/classtypes-1.f95
new file mode 100644
index 00000000000..f16f42fc3af
--- /dev/null
+++ b/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
diff --git a/libgomp/testsuite/libgomp.oacc-fortran/classtypes-2.f95 b/libgomp/testsuite/libgomp.oacc-fortran/classtypes-2.f95
new file mode 100644
index 00000000000..ad80ec2a0ef
--- /dev/null
+++ b/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
--
2.23.0