From patchwork Tue Oct 8 13:37:16 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Julian Brown X-Patchwork-Id: 1173331 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-510470-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="YmK1sWH6"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 46ndhC1sfwz9sN1 for ; Wed, 9 Oct 2019 00:37:45 +1100 (AEDT) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:from :to:cc:subject:date:message-id:mime-version :content-transfer-encoding:content-type; q=dns; s=default; b=AiX 2MIGgcQ0lZE+Qqzx//Nyuo4rgT5jUGD1/28jiOY/NL5Qf2MkXOpQfb3x5RkrPeYg YN4O4hrxsKD5PLyqdr3gF0RPqa7NTi4XnSzznw6GYNa8q7qjjPooPuAhVx1XD5t/ A3fPDujjrNTM4UZxQ+iEAQ8rrC6Ar0otJ+8qWUEQ= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:from :to:cc:subject:date:message-id:mime-version :content-transfer-encoding:content-type; s=default; bh=EOYP8mGLc zHFW0sFUy+KIBkbA/A=; b=YmK1sWH6qSP6P3YnCwn4ExdXdDs19tgRzzpCvCcX0 6vDwvUUcXhkyXuhIJOLCXV5Jxq+sBJy/JlD9vZMSDkzRAf3FaEezKe+XD+apKDD0 /TsB50OgctnybMDfOfVj/+8okWUKZ9sm5N5FckK+NW/fYZH5KLAXetSMFnCBx3iR nA= Received: (qmail 68960 invoked by alias); 8 Oct 2019 13:37:36 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 68944 invoked by uid 89); 8 Oct 2019 13:37:36 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-23.0 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_0, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, KAM_SHORT autolearn=ham version=3.3.1 spammy=gang X-HELO: esa4.mentor.iphmx.com Received: from esa4.mentor.iphmx.com (HELO esa4.mentor.iphmx.com) (68.232.137.252) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Tue, 08 Oct 2019 13:37:30 +0000 IronPort-SDR: tee4xYT18Nrxtx/2n26QOPjWa/LPcCRb4HfLfF4KCqVKVg91x//uUn3v72o2E+ZZjmYTSKcE8M k7QmyHcp9VcepggqNv6gxg0OL5mNuwVzsSVx2gt0hYOHJw9I4tu2UfiS3XP4k86oyIvSAlCpug 6vjSiBQ2lxVL4rVRrPuD/l0kY3NmRnM+MUUlzrAgvhJvf2XPkOZnUHqKp9WZ8s7D4+7Bj5v75B zpZW1q0b4p8bPxDIhDmH0tatuVVmNqxg0W3GNJNM3ysv6LTbIyTz4cH34Rz6QJkK9YFJm36qV8 2SQ= Received: from orw-gwy-02-in.mentorg.com ([192.94.38.167]) by esa4.mentor.iphmx.com with ESMTP; 08 Oct 2019 05:37:27 -0800 IronPort-SDR: FODgCtf9tojaKdXpEgYfcSFfry1J5kRBab1vnbdWQ+LPAHSjp6MOCMES/I3UG7RpzXuYCYhBgN loVnEq6J4kR7LAsK5xQbfot2/ZFqY7T5KrPbDkF9BqzNVg/GPPfJlnhFL0TpGLJfjhB9OMlQi+ lmhLNr8ytX44Qlg37CBiEKd7dIu3qF2CYjS0oPcBK+G/pflBoDDoz3KT59bGwocE6NtV6Nm+rL 0a2SvG8qMwT9uYR43hXMiBFtiX6a9bQV1Xq1IInOxewQyp7jtDvp4lcZJHh6XHRS3N6+tZJHjU MHQ= From: Julian Brown To: CC: Jakub Jelinek , Thomas Schwinge Subject: [PATCH] Fortran polymorphic class-type support for OpenACC Date: Tue, 8 Oct 2019 06:37:16 -0700 Message-ID: <20191008133716.72784-1-julian@codesourcery.com> MIME-Version: 1.0 X-IsSubscribed: yes 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