This patch fixes lowering of derived-type mappings which select elements of arrays of derived types, and similar. These would previously lead to ICEs.
With this change, update directives and enter/exit data directives can pass through constructs that are no longer recognized by the gimplifier, hence alterations are needed there also. Tested with offloading to AMD GCN. OK for mainline? Thanks, Julian 2020-02-02 Julian Brown <jul...@codesourcery.com> gcc/fortran/ * trans-openmp.c (gfc_trans_omp_clauses): Handle element selection for arrays of derived types. gcc/ * gimplify.c (gimplify_scan_omp_clauses): Handle ATTACH_DETACH for non-decls. gcc/testsuite/ * gfortran.dg/goacc/array-with-dt-1.f90: New test. * gfortran.dg/goacc/array-with-dt-3.f90: Likewise. * gfortran.dg/goacc/array-with-dt-4.f90: Likewise. * gfortran.dg/goacc/array-with-dt-5.f90: Likewise. * gfortran.dg/goacc/derived-classtypes-1.f95: Uncomment previously-broken directives. libgomp/ * testsuite/libgomp.oacc-fortran/derivedtypes-arrays-1.f90: New test. * testsuite/libgomp.oacc-fortran/update-dt-array.f90: Likewise. --- gcc/fortran/trans-openmp.c | 192 ++++++++++-------- gcc/gimplify.c | 12 ++ .../gfortran.dg/goacc/array-with-dt-1.f90 | 11 + .../gfortran.dg/goacc/array-with-dt-3.f90 | 14 ++ .../gfortran.dg/goacc/array-with-dt-4.f90 | 18 ++ .../gfortran.dg/goacc/array-with-dt-5.f90 | 12 ++ ...sstypes-1.f95 => derived-classtypes-1.f90} | 8 +- .../derivedtypes-arrays-1.f90 | 109 ++++++++++ .../libgomp.oacc-fortran/update-dt-array.f90 | 53 +++++ 9 files changed, 344 insertions(+), 85 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/goacc/array-with-dt-1.f90 create mode 100644 gcc/testsuite/gfortran.dg/goacc/array-with-dt-3.f90 create mode 100644 gcc/testsuite/gfortran.dg/goacc/array-with-dt-4.f90 create mode 100644 gcc/testsuite/gfortran.dg/goacc/array-with-dt-5.f90 rename gcc/testsuite/gfortran.dg/goacc/{derived-classtypes-1.f95 => derived-classtypes-1.f90} (95%) create mode 100644 libgomp/testsuite/libgomp.oacc-fortran/derivedtypes-arrays-1.f90 create mode 100644 libgomp/testsuite/libgomp.oacc-fortran/update-dt-array.f90 diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 7be34ef9a35..0ab08dabe9a 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -2675,6 +2675,32 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, tree decl = gfc_trans_omp_variable (n->sym, false); if (DECL_P (decl)) TREE_ADDRESSABLE (decl) = 1; + + gfc_ref *lastref = NULL; + + if (n->expr) + for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT || ref->type == REF_ARRAY) + lastref = ref; + + bool allocatable = false, pointer = false; + + if (lastref && lastref->type == REF_COMPONENT) + { + gfc_component *c = lastref->u.c.component; + + if (c->ts.type == BT_CLASS) + { + pointer = CLASS_DATA (c)->attr.class_pointer; + allocatable = CLASS_DATA (c)->attr.allocatable; + } + else + { + pointer = c->attr.pointer; + allocatable = c->attr.allocatable; + } + } + if (n->expr == NULL || (n->expr->ref->type == REF_ARRAY && n->expr->ref->u.ar.type == AR_FULL)) @@ -2911,74 +2937,79 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, } else if (n->expr && n->expr->expr_type == EXPR_VARIABLE - && n->expr->ref->type == REF_COMPONENT) + && n->expr->ref->type == REF_ARRAY + && !n->expr->ref->next) { - gfc_ref *lastcomp; - - for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next) - if (ref->type == REF_COMPONENT) - lastcomp = ref; - - 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; - + /* An array element or array section which is not part of a + derived type, etc. */ + bool element = n->expr->ref->u.ar.type == AR_ELEMENT; + gfc_trans_omp_array_section (block, n, decl, element, + GOMP_MAP_POINTER, node, node2, + node3, node4); + } + else if (n->expr + && n->expr->expr_type == EXPR_VARIABLE + && (n->expr->ref->type == REF_COMPONENT + || n->expr->ref->type == REF_ARRAY) + && lastref + && lastref->type == REF_COMPONENT + && lastref->u.c.component->ts.type != BT_CLASS + && lastref->u.c.component->ts.type != BT_DERIVED + && !lastref->u.c.component->attr.dimension) + { + /* Derived type access with last component being a scalar. */ 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) + gfc_conv_expr (&se, n->expr); + gfc_add_block_to_block (block, &se.pre); + /* For BT_CHARACTER a pointer is returned. */ + OMP_CLAUSE_DECL (node) + = POINTER_TYPE_P (TREE_TYPE (se.expr)) + ? build_fold_indirect_ref (se.expr) : se.expr; + gfc_add_block_to_block (block, &se.post); + if (pointer || allocatable) { - /* Last component is a scalar. */ - gfc_conv_expr (&se, n->expr); - gfc_add_block_to_block (block, &se.pre); - /* For BT_CHARACTER a pointer is returned. */ - OMP_CLAUSE_DECL (node) + node2 = build_omp_clause (input_location, + OMP_CLAUSE_MAP); + gomp_map_kind kind + = (openacc ? GOMP_MAP_ATTACH_DETACH + : GOMP_MAP_ALWAYS_POINTER); + OMP_CLAUSE_SET_MAP_KIND (node2, kind); + OMP_CLAUSE_DECL (node2) = POINTER_TYPE_P (TREE_TYPE (se.expr)) - ? build_fold_indirect_ref (se.expr) : se.expr; - gfc_add_block_to_block (block, &se.post); - if (sym_attr.pointer || sym_attr.allocatable) + ? se.expr + : gfc_build_addr_expr (NULL, se.expr); + OMP_CLAUSE_SIZE (node2) = size_int (0); + if (!openacc + && n->expr->ts.type == BT_CHARACTER + && n->expr->ts.deferred) { - node2 = build_omp_clause (input_location, + gcc_assert (se.string_length); + tree tmp + = gfc_get_char_type (n->expr->ts.kind); + OMP_CLAUSE_SIZE (node) + = fold_build2 (MULT_EXPR, size_type_node, + fold_convert (size_type_node, + se.string_length), + TYPE_SIZE_UNIT (tmp)); + node3 = build_omp_clause (input_location, OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node2, - openacc - ? GOMP_MAP_ATTACH_DETACH - : GOMP_MAP_ALWAYS_POINTER); - OMP_CLAUSE_DECL (node2) - = POINTER_TYPE_P (TREE_TYPE (se.expr)) - ? se.expr : gfc_build_addr_expr (NULL, se.expr); - OMP_CLAUSE_SIZE (node2) = size_int (0); - if (!openacc - && n->expr->ts.type == BT_CHARACTER - && n->expr->ts.deferred) - { - gcc_assert (se.string_length); - tree tmp = gfc_get_char_type (n->expr->ts.kind); - OMP_CLAUSE_SIZE (node) - = fold_build2 (MULT_EXPR, size_type_node, - fold_convert (size_type_node, - se.string_length), - TYPE_SIZE_UNIT (tmp)); - node3 = build_omp_clause (input_location, - OMP_CLAUSE_MAP); - OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_TO); - OMP_CLAUSE_DECL (node3) = se.string_length; - OMP_CLAUSE_SIZE (node3) - = TYPE_SIZE_UNIT (gfc_charlen_type_node); - } + OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_TO); + OMP_CLAUSE_DECL (node3) = se.string_length; + OMP_CLAUSE_SIZE (node3) + = TYPE_SIZE_UNIT (gfc_charlen_type_node); } - goto finalize_map_clause; } - + } + else if (n->expr + && n->expr->expr_type == EXPR_VARIABLE + && (n->expr->ref->type == REF_COMPONENT + || n->expr->ref->type == REF_ARRAY)) + { + gfc_init_se (&se, NULL); se.expr = gfc_maybe_dereference_var (n->sym, decl); - for (gfc_ref *ref = n->expr->ref; - ref && ref != lastcomp->next; - ref = ref->next) + for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next) { if (ref->type == REF_COMPONENT) { @@ -2987,24 +3018,30 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, gfc_conv_component_ref (&se, ref); } + else if (ref->type == REF_ARRAY) + { + if (ref->u.ar.type == AR_ELEMENT && ref->next) + gfc_conv_array_ref (&se, &ref->u.ar, n->expr, + &n->expr->where); + else + gcc_assert (!ref->next); + } else - sorry ("unhandled derived-type component"); + sorry ("unhandled expression type"); } tree inner = se.expr; /* 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 (lastref->type == REF_COMPONENT + && (lastref->u.c.component->ts.type == BT_DERIVED + || lastref->u.c.component->ts.type == BT_CLASS)) { - bool pointer - = (lastcomp->u.c.component->ts.type == BT_CLASS - ? sym_attr.class_pointer : sym_attr.pointer); - if (pointer || (openacc && sym_attr.allocatable)) + if (pointer || (openacc && allocatable)) { tree data, size; - if (lastcomp->u.c.component->ts.type == BT_CLASS) + if (lastref->u.c.component->ts.type == BT_CLASS) { data = gfc_class_data_get (inner); size = gfc_class_vtab_size_get (inner); @@ -3037,9 +3074,8 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, = TYPE_SIZE_UNIT (TREE_TYPE (inner)); } } - else if (lastcomp->next - && lastcomp->next->type == REF_ARRAY - && lastcomp->next->u.ar.type == AR_FULL) + else if (lastref->type == REF_ARRAY + && lastref->u.ar.type == AR_FULL) { /* Just pass the (auto-dereferenced) decl through for bare attach and detach clauses. */ @@ -3133,27 +3169,21 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, else OMP_CLAUSE_DECL (node) = inner; } - else /* An array element or section. */ + else if (lastref->type == REF_ARRAY) { - bool element - = (lastcomp->next - && lastcomp->next->type == REF_ARRAY - && lastcomp->next->u.ar.type == AR_ELEMENT); - + /* An array element or section. */ + bool element = lastref->u.ar.type == AR_ELEMENT; gomp_map_kind kind = (openacc ? GOMP_MAP_ATTACH_DETACH : GOMP_MAP_ALWAYS_POINTER); gfc_trans_omp_array_section (block, n, inner, element, kind, node, node2, node3, node4); } + else + gcc_unreachable (); } - else /* An array element or array section. */ - { - bool element = n->expr->ref->u.ar.type == AR_ELEMENT; - gfc_trans_omp_array_section (block, n, decl, element, - GOMP_MAP_POINTER, node, node2, - node3, node4); - } + else + sorry ("unhandled expression"); finalize_map_clause: diff --git a/gcc/gimplify.c b/gcc/gimplify.c index 95d55bb8ba4..62fb6370819 100644 --- a/gcc/gimplify.c +++ b/gcc/gimplify.c @@ -9406,6 +9406,18 @@ gimplify_scan_omp_clauses (tree *list_p, gimple_seq *pre_p, } } } + else if ((code == OACC_ENTER_DATA + || code == OACC_EXIT_DATA + || code == OACC_DATA + || code == OACC_PARALLEL + || code == OACC_KERNELS + || code == OACC_SERIAL) + && OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_ATTACH_DETACH) + { + gomp_map_kind k = (code == OACC_EXIT_DATA + ? GOMP_MAP_DETACH : GOMP_MAP_ATTACH); + OMP_CLAUSE_SET_MAP_KIND (c, k); + } if (gimplify_expr (pd, pre_p, NULL, is_gimple_lvalue, fb_lvalue) == GS_ERROR) diff --git a/gcc/testsuite/gfortran.dg/goacc/array-with-dt-1.f90 b/gcc/testsuite/gfortran.dg/goacc/array-with-dt-1.f90 new file mode 100644 index 00000000000..4a3ff0ef3a7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/goacc/array-with-dt-1.f90 @@ -0,0 +1,11 @@ +type t + integer, allocatable :: A(:,:) +end type t + +type(t), allocatable :: b(:) + +!$acc update host(b) +!$acc update host(b(:)) +!$acc update host(b(1)%A) +!$acc update host(b(1)%A(:,:)) +end diff --git a/gcc/testsuite/gfortran.dg/goacc/array-with-dt-3.f90 b/gcc/testsuite/gfortran.dg/goacc/array-with-dt-3.f90 new file mode 100644 index 00000000000..dcb63657f2b --- /dev/null +++ b/gcc/testsuite/gfortran.dg/goacc/array-with-dt-3.f90 @@ -0,0 +1,14 @@ +type t2 + integer :: A(200,200) +end type t2 +type t + integer, allocatable :: A(:,:) +end type t + +type(t2),allocatable :: c(:) +type(t), allocatable :: d(:) + +!$acc exit data delete(c(1)%A) +!$acc exit data delete(d(1)%A) + +end diff --git a/gcc/testsuite/gfortran.dg/goacc/array-with-dt-4.f90 b/gcc/testsuite/gfortran.dg/goacc/array-with-dt-4.f90 new file mode 100644 index 00000000000..637d5f57e1c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/goacc/array-with-dt-4.f90 @@ -0,0 +1,18 @@ +type t4 + integer, allocatable :: quux(:) +end type t4 +type t3 + type(t4), pointer :: qux(:) +end type t3 +type t2 + type(t3), allocatable :: bar(:) +end type t2 +type t + type(t2), allocatable :: foo(:) +end type t + +type(t), allocatable :: c(:) + +!$acc enter data copyin(c(5)%foo(4)%bar(3)%qux(2)%quux(:)) +!$acc exit data delete(c(5)%foo(4)%bar(3)%qux(2)%quux(:)) +end diff --git a/gcc/testsuite/gfortran.dg/goacc/array-with-dt-5.f90 b/gcc/testsuite/gfortran.dg/goacc/array-with-dt-5.f90 new file mode 100644 index 00000000000..900587b7eaf --- /dev/null +++ b/gcc/testsuite/gfortran.dg/goacc/array-with-dt-5.f90 @@ -0,0 +1,12 @@ +type t2 + integer :: bar +end type t2 +type t + type(t2), pointer :: foo +end type t + +type(t) :: c + +!$acc enter data copyin(c%foo) + +end diff --git a/gcc/testsuite/gfortran.dg/goacc/derived-classtypes-1.f95 b/gcc/testsuite/gfortran.dg/goacc/derived-classtypes-1.f90 similarity index 95% rename from gcc/testsuite/gfortran.dg/goacc/derived-classtypes-1.f95 rename to gcc/testsuite/gfortran.dg/goacc/derived-classtypes-1.f90 index e6cf09c6d3c..85a2e1d373d 100644 --- a/gcc/testsuite/gfortran.dg/goacc/derived-classtypes-1.f95 +++ b/gcc/testsuite/gfortran.dg/goacc/derived-classtypes-1.f90 @@ -71,7 +71,7 @@ class(type7), allocatable :: acshiela !$acc enter data copyin(bar) !$acc enter data copyin(bar%b) !$acc enter data copyin(qux) -!!$acc enter data copyin(qux%c) +!$acc enter data copyin(qux%c) !$acc enter data copyin(quux) !$acc enter data copyin(quux%d) !$acc enter data copyin(fred) @@ -86,7 +86,7 @@ class(type7), allocatable :: acshiela !$acc enter data copyin(pbar) !$acc enter data copyin(pbar%b) !$acc enter data copyin(pqux) -!!$acc enter data copyin(pqux%c) +!$acc enter data copyin(pqux%c) !$acc enter data copyin(pquux) !$acc enter data copyin(pquux%d) !$acc enter data copyin(pfred) @@ -101,7 +101,7 @@ class(type7), allocatable :: acshiela !$acc enter data copyin(cbar) !$acc enter data copyin(cbar%b) !$acc enter data copyin(cqux) -!!$acc enter data copyin(cqux%c) +!$acc enter data copyin(cqux%c) !$acc enter data copyin(cquux) !$acc enter data copyin(cquux%d) !$acc enter data copyin(cfred) @@ -116,7 +116,7 @@ class(type7), allocatable :: acshiela !$acc enter data copyin(acbar) !$acc enter data copyin(acbar%b) !$acc enter data copyin(acqux) -!!$acc enter data copyin(acqux%c) +!$acc enter data copyin(acqux%c) !$acc enter data copyin(acquux) !$acc enter data copyin(acquux%d) !$acc enter data copyin(acfred) diff --git a/libgomp/testsuite/libgomp.oacc-fortran/derivedtypes-arrays-1.f90 b/libgomp/testsuite/libgomp.oacc-fortran/derivedtypes-arrays-1.f90 new file mode 100644 index 00000000000..644ad1f6b2f --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/derivedtypes-arrays-1.f90 @@ -0,0 +1,109 @@ +! { dg-do run } + +type type1 + integer, allocatable :: arr1(:,:) +end type type1 + +type type2 + type(type1) :: t1 +end type type2 + +type type3 + type(type2) :: t2(20) +end type type3 + +type type4 + type(type3), allocatable :: t3(:) +end type type4 + +integer :: i, j, k + +type(type4), allocatable :: var1(:) +type(type4) :: var2 +type(type3) :: var3 + +allocate(var1(1:20)) +do i=1,20 + allocate(var1(i)%t3(1:20)) + do j=1,20 + do k=1,20 + allocate(var1(i)%t3(j)%t2(k)%t1%arr1(1:20,1:20)) + end do + end do +end do + +allocate(var2%t3(1:20)) +do i=1,20 + do j=1,20 + allocate(var2%t3(i)%t2(j)%t1%arr1(1:20,1:20)) + end do +end do + +do i=1,20 + do j=1,20 + do k=1,20 + var1(i)%t3(j)%t2(k)%t1%arr1(:,:) = 0 + end do + var2%t3(i)%t2(j)%t1%arr1(:,:) = 0 + end do +end do + +!$acc enter data copyin(var2%t3(4)%t2(3)%t1%arr1(:,:)) +!$acc enter data copyin(var1(5)%t3(4)%t2(3)%t1%arr1(:,:)) + +var2%t3(4)%t2(3)%t1%arr1(:,:) = 5 +var1(5)%t3(4)%t2(3)%t1%arr1(:,:) = 4 + +!$acc update device(var2%t3(4)%t2(3)%t1%arr1) +!$acc update device(var1(5)%t3(4)%t2(3)%t1%arr1) + +!$acc exit data copyout(var1(5)%t3(4)%t2(3)%t1%arr1(:,:)) +!$acc exit data copyout(var2%t3(4)%t2(3)%t1%arr1(:,:)) + +do i=1,20 + do j=1,20 + do k=1,20 + if (i.eq.5 .and. j.eq.4 .and. k.eq.3) then + if (any(var1(i)%t3(j)%t2(k)%t1%arr1 .ne. 4)) stop 1 + else + if (any(var1(i)%t3(j)%t2(k)%t1%arr1 .ne. 0)) stop 2 + end if + end do + if (i.eq.4 .and. j.eq.3) then + if (any(var2%t3(i)%t2(j)%t1%arr1 .ne. 5)) stop 3 + else + if (any(var2%t3(i)%t2(j)%t1%arr1 .ne. 0)) stop 4 + end if + end do +end do + +do i=1,20 + allocate(var3%t2(i)%t1%arr1(1:20, 1:20)) + var3%t2(i)%t1%arr1(:,:) = 0 +end do + +!$acc enter data copyin(var3) +!$acc enter data copyin(var3%t2(:)) +!$acc enter data copyin(var3%t2(5)%t1) +!$acc data copyin(var3%t2(5)%t1%arr1) + +!$acc serial present(var3%t2(5)%t1%arr1) +var3%t2(5)%t1%arr1(:,:) = 6 +!$acc end serial + +!$acc update host(var3%t2(5)%t1%arr1) + +!$acc end data +!$acc exit data delete(var3%t2(5)%t1) +!$acc exit data delete(var3%t2) +!$acc exit data delete(var3) + +do i=1,20 + if (i.eq.5) then + if (any(var3%t2(i)%t1%arr1.ne.6)) stop 5 + else + if (any(var3%t2(i)%t1%arr1.ne.0)) stop 6 + end if +end do + +end diff --git a/libgomp/testsuite/libgomp.oacc-fortran/update-dt-array.f90 b/libgomp/testsuite/libgomp.oacc-fortran/update-dt-array.f90 new file mode 100644 index 00000000000..d796eddceda --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/update-dt-array.f90 @@ -0,0 +1,53 @@ +! { dg-do run } + +program myprog + + type mytype + integer, allocatable :: myarr(:,:) + end type mytype + integer :: i + + type(mytype), allocatable :: typearr(:) + + allocate(typearr(1:100)) + + do i=1,100 + allocate(typearr(i)%myarr(1:100,1:100)) + end do + + do i=1,100 + typearr(i)%myarr(:,:) = 0 + end do + + !$acc enter data copyin(typearr) + + do i=1,100 + !$acc enter data copyin(typearr(i)%myarr) + end do + + i=33 + typearr(i)%myarr(:,:) = 50 + + !$acc update device(typearr(i)%myarr(:,:)) + + do i=1,100 + !$acc exit data copyout(typearr(i)%myarr) + end do + + !$acc exit data delete(typearr) + + do i=1,100 + if (i.eq.33) then + if (any(typearr(i)%myarr.ne.50)) stop 1 + else + if (any(typearr(i)%myarr.ne.0)) stop 2 + end if + end do + + do i=1,100 + deallocate(typearr(i)%myarr) + end do + + deallocate(typearr) + +end program myprog -- 2.29.2