2015-01-27 Tobias Burnus <burnus@net-b.de>
PR fortran/63861
gcc/fortran/
* trans-openmp.c (gfc_has_alloc_comps, gfc_trans_omp_clauses):
Fix handling for scalar coarrays.
* trans-types.c (gfc_get_element_type): Add comment.
gcc/testsuite/
* gfortran.dg/goacc/coarray_2.f90: New.
@@ -190,5 +190,5 @@ gfc_has_alloc_comps (tree type, tree decl)
}
- while (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type))
+ if (GFC_DESCRIPTOR_TYPE_P (type) || GFC_ARRAY_TYPE_P (type))
type = gfc_get_element_type (type);
@@ -1990,5 +1990,8 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
= gfc_conv_descriptor_data_get (decl);
OMP_CLAUSE_SIZE (node3) = size_int (0);
- if (n->sym->attr.pointer)
+
+ /* We have to check for n->sym->attr.dimension because
+ of scalar coarrays. */
+ if (n->sym->attr.pointer && n->sym->attr.dimension)
{
stmtblock_t cond_block;
@@ -2020,14 +2023,17 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
OMP_CLAUSE_SIZE (node) = size;
}
- else
+ else if (n->sym->attr.dimension)
OMP_CLAUSE_SIZE (node)
= gfc_full_array_size (block, decl,
GFC_TYPE_ARRAY_RANK (type));
- tree elemsz
- = TYPE_SIZE_UNIT (gfc_get_element_type (type));
- elemsz = fold_convert (gfc_array_index_type, elemsz);
- OMP_CLAUSE_SIZE (node)
- = fold_build2 (MULT_EXPR, gfc_array_index_type,
- OMP_CLAUSE_SIZE (node), elemsz);
+ if (n->sym->attr.dimension)
+ {
+ tree elemsz
+ = TYPE_SIZE_UNIT (gfc_get_element_type (type));
+ elemsz = fold_convert (gfc_array_index_type, elemsz);
+ OMP_CLAUSE_SIZE (node)
+ = fold_build2 (MULT_EXPR, gfc_array_index_type,
+ OMP_CLAUSE_SIZE (node), elemsz);
+ }
}
else
@@ -1173,4 +1173,8 @@ gfc_conv_array_bound (gfc_expr * expr)
}
+/* Return the type of an element of the array. Note that scalar coarrays
+ are special. In particular, for GFC_ARRAY_TYPE_P, the original argument
+ (with POINTER_TYPE stripped) is returned. */
+
tree
gfc_get_element_type (tree type)
new file mode 100644
@@ -0,0 +1,108 @@
+! { dg-do compile }
+! { dg-additional-options "-fcoarray=lib" }
+!
+! PR fortran/63861
+
+module test
+contains
+ subroutine oacc1(a)
+ implicit none
+ integer :: i
+ integer, codimension[*] :: a
+ !$acc declare device_resident (a)
+ !$acc data copy (a)
+ !$acc end data
+ !$acc data deviceptr (a)
+ !$acc end data
+ !$acc parallel private (a)
+ !$acc end parallel
+ !$acc host_data use_device (a)
+ !$acc end host_data
+ !$acc parallel loop reduction(+:a)
+ do i = 1,5
+ enddo
+ !$acc end parallel loop
+ !$acc parallel loop
+ do i = 1,5
+ enddo
+ !$acc end parallel loop
+ !$acc update device (a)
+ !$acc update host (a)
+ !$acc update self (a)
+ end subroutine oacc1
+
+ subroutine oacc2(a)
+ implicit none
+ integer :: i
+ integer, allocatable, codimension[:] :: a
+ !$acc declare device_resident (a)
+ !$acc data copy (a)
+ !$acc end data
+ !$acc parallel private (a)
+ !$acc end parallel
+! FIXME:
+! !$acc parallel loop reduction(+:a)
+! This involves an assignment, which shall not reallocate
+! the LHS variable. Version without reduction:
+ !$acc parallel loop
+ do i = 1,5
+ enddo
+ !$acc end parallel loop
+ !$acc parallel loop
+ do i = 1,5
+ enddo
+ !$acc end parallel loop
+ !$acc update device (a)
+ !$acc update host (a)
+ !$acc update self (a)
+ end subroutine oacc2
+
+ subroutine oacc3(a)
+ implicit none
+ integer :: i
+ integer, codimension[*] :: a(:)
+ !$acc declare device_resident (a)
+ !$acc data copy (a)
+ !$acc end data
+ !$acc data deviceptr (a)
+ !$acc end data
+ !$acc parallel private (a)
+ !$acc end parallel
+ !$acc host_data use_device (a)
+ !$acc end host_data
+ !$acc parallel loop reduction(+:a)
+ do i = 1,5
+ enddo
+ !$acc end parallel loop
+ !$acc parallel loop
+ do i = 1,5
+ enddo
+ !$acc end parallel loop
+ !$acc update device (a)
+ !$acc update host (a)
+ !$acc update self (a)
+ end subroutine oacc3
+
+ subroutine oacc4(a)
+ implicit none
+ integer :: i
+ integer, allocatable, codimension[:] :: a(:)
+ !$acc declare device_resident (a)
+ !$acc data copy (a)
+ !$acc end data
+ !$acc parallel private (a)
+ !$acc end parallel
+ !$acc parallel loop reduction(+:a)
+ do i = 1,5
+ enddo
+ !$acc end parallel loop
+ !$acc parallel loop
+ do i = 1,5
+ enddo
+ !$acc end parallel loop
+ !$acc update device (a)
+ !$acc update host (a)
+ !$acc update self (a)
+ end subroutine oacc4
+end module test
+! { dg-excess-errors "sorry, unimplemented: directive not yet implemented" }