gcc/fortran/ChangeLog.fortran-caf | 5
gcc/fortran/trans-intrinsic.c | 36 ++
gcc/testsuite/ChangeLog.fortran-caf | 3
gcc/testsuite/gfortran.dg/coarray/send_array.f90 | 299 +++++++++++++++++++++++
libgfortran/ChangeLog.fortran-caf | 9
libgfortran/caf/libcaf.h | 8
libgfortran/caf/single.c | 100 +++++--
7 files changed, 418 insertions(+), 42 deletions(-)
===================================================================
@@ -1,3 +1,8 @@
+2014-04-06 Tobias Burnus <burnus@net-b.de>
+
+ * trans-intrinsic.c (conv_caf_send): Fix bugs with
+ arrays implementation.
+
2014-04-03 Tobias Burnus <burnus@net-b.de>
* trans.h (gfor_fndecl_caf_send_desc,
===================================================================
@@ -7871,9 +7871,9 @@ conv_caf_send (gfc_code *code) {
gcc_assert (gfc_option.coarray == GFC_FCOARRAY_LIB);
- lhs_expr = code->ext.actual->expr;
- rhs_expr = code->ext.actual->next->expr;
- async_expr = code->ext.actual->next->next->expr;
+ lhs_expr = code->ext.actual->expr;
+ rhs_expr = code->ext.actual->next->expr;
+ async_expr = code->ext.actual->next->next->expr;
gfc_init_block (&block);
/* LHS: The coarray. */
@@ -7880,8 +7880,16 @@ conv_caf_send (gfc_code *code) {
gfc_init_se (&lhs_se, NULL);
if (lhs_expr->rank)
- lhs_se.descriptor_only = 1;
- gfc_conv_expr_reference (&lhs_se, lhs_expr);
+ {
+ gfc_conv_expr_descriptor (&lhs_se, lhs_expr);
+ lhs_se.expr = gfc_build_addr_expr (NULL_TREE, lhs_se.expr);
+ }
+ else
+ {
+ lhs_se.want_pointer = 1;
+ gfc_conv_expr_reference (&lhs_se, lhs_expr);
+ }
+ gfc_add_block_to_block (&block, &lhs_se.pre);
caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
@@ -7947,9 +7955,15 @@ conv_caf_send (gfc_code *code) {
gfc_init_se (&rhs_se, NULL);
if (rhs_expr->rank)
- rhs_se.descriptor_only = 1;
- rhs_se.want_pointer = 1;
- gfc_conv_expr_reference (&rhs_se, rhs_expr);
+ {
+ gfc_conv_expr_descriptor (&rhs_se, rhs_expr);
+ rhs_se.expr = gfc_build_addr_expr (NULL_TREE, rhs_se.expr);
+ }
+ else
+ {
+ rhs_se.want_pointer = 1;
+ gfc_conv_expr_reference (&rhs_se, rhs_expr);
+ }
gfc_add_block_to_block (&block, &rhs_se.pre);
gfc_init_se (&async_se, NULL);
@@ -7956,7 +7970,10 @@ conv_caf_send (gfc_code *code) {
gfc_conv_expr (&async_se, async_expr);
if (rhs_expr->rank)
- size = size_in_bytes (gfc_get_element_type (TREE_TYPE (rhs_se.expr)));
+ {
+ size = TREE_TYPE (TREE_TYPE (rhs_se.expr));
+ size = size_in_bytes (gfc_get_element_type (size));
+ }
else
size = size_in_bytes (TREE_TYPE (TREE_TYPE (rhs_se.expr)));
if (lhs_expr->rank && rhs_expr->rank)
@@ -7974,6 +7991,7 @@ conv_caf_send (gfc_code *code) {
token, offset, image_index, rhs_se.expr, size,
fold_convert (boolean_type_node, async_se.expr));
gfc_add_expr_to_block (&block, tmp);
+ gfc_add_block_to_block (&block, &lhs_se.post);
gfc_add_block_to_block (&block, &rhs_se.post);
return gfc_finish_block (&block);
}
===================================================================
@@ -1,3 +1,12 @@
+2014-04-06 Tobias Burnus <burnus@net-b.de>
+
+ * caf/libcaf.h (_gfortran_caf_send_desc,
+ _gfortran_caf_send_desc_scalar, _gfortran_caf_send): Renamed
+ from _gfortran_send*.
+ * caf/single.c (_gfortran_caf_send_desc,
+ _gfortran_caf_send_desc_scalar): Fix bugs and also
+ support rank > 1 arrays.
+
2014-04-03 Tobias Burnus <burnus@net-b.de>
* caf/libcaf.h (descriptor_dimension, gfc_descriptor_t): New
===================================================================
@@ -108,9 +108,11 @@ void *_gfortran_caf_register (size_t, caf_register
char *, int);
void _gfortran_caf_deregister (caf_token_t *, int *, char *, int);
-void _gfortran_send (caf_token_t, size_t, int, void *, size_t, bool);
-void _gfortran_send_desc (caf_token_t, size_t, int, gfc_descriptor_t*, gfc_descriptor_t*, bool);
-void _gfortran_send_desc_scalar (caf_token_t, size_t, int, gfc_descriptor_t*, void*, bool);
+void _gfortran_caf_send (caf_token_t, size_t, int, void *, size_t, bool);
+void _gfortran_caf_send_desc (caf_token_t, size_t, int, gfc_descriptor_t*,
+ gfc_descriptor_t*, bool);
+void _gfortran_caf_send_desc_scalar (caf_token_t, size_t, int,
+ gfc_descriptor_t*, void*, bool);
void _gfortran_caf_sync_all (int *, char *, int);
void _gfortran_caf_sync_images (int, int[], int *, char *, int);
===================================================================
@@ -170,30 +170,57 @@ _gfortran_caf_send_desc (caf_token_t token, size_t
gfc_descriptor_t *dest, gfc_descriptor_t *src,
bool asyn __attribute__ ((unused)))
{
- fprintf (stderr, "COARRAY ERROR: Array communication "
- "[_gfortran_caf_send_desc] not yet implemented for rank /= 0");
- exit (EXIT_FAILURE);
- size_t i, j;
- size_t size = GFC_DESCRIPTOR_SIZE (dest);
+ size_t i, size;
+ int j;
int rank = GFC_DESCRIPTOR_RANK (dest);
- if (rank != 1)
+ size = 1;
+ for (j = 0; j < rank; j++)
{
- fprintf (stderr, "COARRAY ERROR: Array communication "
- "[_gfortran_caf_send_desc] not yet implemented for rank /= 0");
- exit (EXIT_FAILURE);
+ ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
+ if (dimextent < 0)
+ dimextent = 0;
+ size *= dimextent;
}
- for (j = dest->dim[0].lower_bound - dest->offset,
- i = src->dim[0].lower_bound - src->offset;
- j <= dest->dim[0]._ubound - dest->offset
- && i <= src->dim[0]._ubound - src->offset;
- j += dest->dim[0]._stride,
- i += src->dim[0]._stride)
+ if (size == 0)
+ return;
+
+ for (i = 0; i < size; i++)
{
- void *dst = (void *)((char *) TOKEN(token) + offset + j*size);
- void *sr = (void *)((char *)src->base_addr + j*size);
- memmove (dst, sr, size);
+ ptrdiff_t array_offset_dst = 0;
+ ptrdiff_t stride = 1;
+ ptrdiff_t extent = 1;
+ for (j = 0; j < rank-1; j++)
+ {
+ array_offset_dst += ((i / (extent*stride))
+ % (dest->dim[j]._ubound
+ - dest->dim[j].lower_bound + 1))
+ * dest->dim[j]._stride;
+ extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
+ stride = dest->dim[j]._stride;
+ }
+ array_offset_dst += (i / extent) * dest->dim[rank-1]._stride;
+
+ ptrdiff_t array_offset_sr = 0;
+ stride = 1;
+ extent = 1;
+ for (j = 0; j < GFC_DESCRIPTOR_RANK (src)-1; j++)
+ {
+ array_offset_sr += ((i / (extent*stride))
+ % (src->dim[j]._ubound
+ - src->dim[j].lower_bound + 1))
+ * src->dim[j]._stride;
+ extent = (src->dim[j]._ubound - src->dim[j].lower_bound + 1);
+ stride = src->dim[j]._stride;
+ }
+ array_offset_sr += (i / extent) * dest->dim[rank-1]._stride;
+
+ void *dst = (void *)((char *) TOKEN (token) + offset
+ + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest));
+ void *sr = (void *)((char *) src->base_addr
+ + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
+ memmove (dst, sr, GFC_DESCRIPTOR_SIZE (dest));
}
}
@@ -206,24 +233,37 @@ _gfortran_caf_send_desc_scalar (caf_token_t token,
gfc_descriptor_t *dest, void *buffer,
bool asyn __attribute__ ((unused)))
{
- size_t j;
- size_t size = GFC_DESCRIPTOR_SIZE (dest);
+ size_t i, size;
+ int j;
int rank = GFC_DESCRIPTOR_RANK (dest);
- if (rank != 1)
+ size = 1;
+ for (j = 0; j < rank; j++)
{
- fprintf (stderr, "COARRAY ERROR: Array communication "
- "[_gfortran_caf_send_desc_scalar] not yet implemented for "
- "rank /= 0");
- exit (EXIT_FAILURE);
+ ptrdiff_t dimextent = dest->dim[j]._ubound - dest->dim[j].lower_bound + 1;
+ if (dimextent < 0)
+ dimextent = 0;
+ size *= dimextent;
}
- for (j = dest->dim[0].lower_bound - dest->offset;
- j <= dest->dim[0]._ubound - dest->offset;
- j += dest->dim[0]._stride)
+ for (i = 0; i < size; i++)
{
- void *dst = (void *)((char *) TOKEN(token) + offset + j*size);
- memmove (dst, buffer, size);
+ ptrdiff_t array_offset = 0;
+ ptrdiff_t stride = 1;
+ ptrdiff_t extent = 1;
+ for (j = 0; j < rank-1; j++)
+ {
+ array_offset += ((i / (extent*stride))
+ % (dest->dim[j]._ubound
+ - dest->dim[j].lower_bound + 1))
+ * dest->dim[j]._stride;
+ extent = (dest->dim[j]._ubound - dest->dim[j].lower_bound + 1);
+ stride = dest->dim[j]._stride;
+ }
+ array_offset += (i / extent) * dest->dim[rank-1]._stride;
+ void *dst = (void *)((char *) TOKEN (token) + offset
+ + array_offset*GFC_DESCRIPTOR_SIZE (dest));
+ memmove (dst, buffer, GFC_DESCRIPTOR_SIZE (dest));
}
}
===================================================================
@@ -0,0 +1,3 @@
+2014-04-06 Tobias Burnus <burnus@net-b.de>
+
+ * gfortran.dg/coarray/send_array.f90: New.
===================================================================
@@ -0,0 +1,299 @@
+! { dg-do run }
+!
+! This program does a correctness check for
+! ARRAY = SCALAR and ARRAY = ARRAY
+!
+program main
+ implicit none
+ integer, parameter :: n = 3
+ integer, parameter :: m = 4
+
+ ! Allocatable coarrays
+ call one(-5, 1)
+ call one(0, 0)
+ call one(1, -5)
+ call one(0, -11)
+
+ ! Static coarrays
+ call two()
+ call three()
+contains
+subroutine one(lb1, lb2)
+ integer, value :: lb1, lb2
+
+ integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s
+ integer, allocatable :: caf(:,:)[:]
+ integer, allocatable :: a(:,:), b(:,:)
+
+ allocate(caf(lb1:n+lb1-1, lb2:m+lb2-1)[*], &
+ a(lb1:n+lb1-1, lb2:m+lb2-1), &
+ b(lb1:n+lb1-1, lb2:m+lb2-1))
+
+ b = reshape([(i*33, i = 1, size(b))], shape(b))
+
+ ! Whole array: ARRAY = SCALAR
+ caf = -42
+ a = -42
+ a(:,:) = b(lb1, lb2)
+ sync all
+ if (this_image() == 1) then
+ caf(:,:)[this_image()] = b(lb1, lb2)
+ end if
+ sync all
+ if (this_image() == num_images()) then
+ if (any (a /= caf)) &
+ call abort()
+ end if
+
+ ! Whole array: ARRAY = ARRAY
+ caf = -42
+ a = -42
+ a(:,:) = b(:, :)
+ sync all
+ if (this_image() == 1) then
+ caf(:,:)[this_image()] = b(:, :)
+ end if
+ sync all
+ if (this_image() == num_images()) then
+ if (any (a /= caf)) &
+ call abort()
+ end if
+
+ ! Array sections with different ranges and pos/neg strides
+ do i_sgn1 = -1, 1, 2
+ do i_sgn2 = -1, 1, 2
+ do i=lb1, n+lb1-1
+ do i_e=lb1, n+lb1-1
+ do i_s=1, n
+ do j=lb2, m+lb2-1
+ do j_e=lb2, m+lb2-1
+ do j_s=1, m
+ ! ARRAY = SCALAR
+ caf = -42
+ a = -42
+ a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) = b(lb1, lb2)
+ sync all
+ if (this_image() == 1) then
+ caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[1] = b(lb1, lb2)
+ end if
+ sync all
+
+ ! ARRAY = ARRAY
+ caf = -42
+ a = -42
+ a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
+ = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
+ sync all
+ if (this_image() == 1) then
+ caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[1] &
+ = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
+ end if
+ sync all
+
+ if (this_image() == num_images()) then
+ if (any (a /= caf)) then
+ print '(*(g0))', "bounds: ", lb1,":",n+lb1-1,", ", &
+ lb2,":",m+lb2-1
+ print '(*(g0))', "section: ", i,":",i_e,":",i_s*i_sgn1, &
+ ", ", j,":",j_e,":",j_s*i_sgn2
+ print *, i
+ print *, a
+ print *, caf
+ print *, a-caf
+ call abort()
+ endif
+ end if
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+end subroutine one
+
+subroutine two()
+ integer, parameter :: lb1 = -5, lb2 = 1
+
+ integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s
+ integer, save :: caf(lb1:n+lb1-1, lb2:m+lb2-1)[*]
+ integer, save :: a(lb1:n+lb1-1, lb2:m+lb2-1)
+ integer, save :: b(lb1:n+lb1-1, lb2:m+lb2-1)
+
+ b = reshape([(i*33, i = 1, size(b))], shape(b))
+
+ ! Whole array: ARRAY = SCALAR
+ caf = -42
+ a = -42
+ a(:,:) = b(lb1, lb2)
+ sync all
+ if (this_image() == 1) then
+ caf(:,:)[this_image()] = b(lb1, lb2)
+ end if
+ sync all
+ if (this_image() == num_images()) then
+ if (any (a /= caf)) &
+ call abort()
+ end if
+
+ ! Whole array: ARRAY = ARRAY
+ caf = -42
+ a = -42
+ a(:,:) = b(:, :)
+ sync all
+ if (this_image() == 1) then
+ caf(:,:)[this_image()] = b(:, :)
+ end if
+ sync all
+ if (this_image() == num_images()) then
+ if (any (a /= caf)) &
+ call abort()
+ end if
+
+ ! Array sections with different ranges and pos/neg strides
+ do i_sgn1 = -1, 1, 2
+ do i_sgn2 = -1, 1, 2
+ do i=lb1, n+lb1-1
+ do i_e=lb1, n+lb1-1
+ do i_s=1, n
+ do j=lb2, m+lb2-1
+ do j_e=lb2, m+lb2-1
+ do j_s=1, m
+ ! ARRAY = SCALAR
+ caf = -42
+ a = -42
+ a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) = b(lb1, lb2)
+ sync all
+ if (this_image() == 1) then
+ caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[1] = b(lb1, lb2)
+ end if
+ sync all
+
+ ! ARRAY = ARRAY
+ caf = -42
+ a = -42
+ a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
+ = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
+ sync all
+ if (this_image() == 1) then
+ caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[1] &
+ = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
+ end if
+ sync all
+
+ if (this_image() == num_images()) then
+ if (any (a /= caf)) then
+ print '(*(g0))', "bounds: ", lb1,":",n+lb1-1,", ", &
+ lb2,":",m+lb2-1
+ print '(*(g0))', "section: ", i,":",i_e,":",i_s*i_sgn1, &
+ ", ", j,":",j_e,":",j_s*i_sgn2
+ print *, i
+ print *, a
+ print *, caf
+ print *, a-caf
+ call abort()
+ endif
+ end if
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+end subroutine two
+
+subroutine three()
+ integer, parameter :: lb1 = 0, lb2 = 0
+
+ integer :: i_sgn1, i_sgn2, i, i_e, i_s, j, j_e, j_s
+ integer, save :: caf(lb1:n+lb1-1, lb2:m+lb2-1)[*]
+ integer, save :: a(lb1:n+lb1-1, lb2:m+lb2-1)
+ integer, save :: b(lb1:n+lb1-1, lb2:m+lb2-1)
+
+ b = reshape([(i*33, i = 1, size(b))], shape(b))
+
+ ! Whole array: ARRAY = SCALAR
+ caf = -42
+ a = -42
+ a(:,:) = b(lb1, lb2)
+ sync all
+ if (this_image() == 1) then
+ caf(:,:)[this_image()] = b(lb1, lb2)
+ end if
+ sync all
+ if (this_image() == num_images()) then
+ if (any (a /= caf)) &
+ call abort()
+ end if
+
+ ! Whole array: ARRAY = ARRAY
+ caf = -42
+ a = -42
+ a(:,:) = b(:, :)
+ sync all
+ if (this_image() == 1) then
+ caf(:,:)[this_image()] = b(:, :)
+ end if
+ sync all
+ if (this_image() == num_images()) then
+ if (any (a /= caf)) &
+ call abort()
+ end if
+
+ ! Array sections with different ranges and pos/neg strides
+ do i_sgn1 = -1, 1, 2
+ do i_sgn2 = -1, 1, 2
+ do i=lb1, n+lb1-1
+ do i_e=lb1, n+lb1-1
+ do i_s=1, n
+ do j=lb2, m+lb2-1
+ do j_e=lb2, m+lb2-1
+ do j_s=1, m
+ ! ARRAY = SCALAR
+ caf = -42
+ a = -42
+ a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) = b(lb1, lb2)
+ sync all
+ if (this_image() == 1) then
+ caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[1] = b(lb1, lb2)
+ end if
+ sync all
+
+ ! ARRAY = ARRAY
+ caf = -42
+ a = -42
+ a(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2) &
+ = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
+ sync all
+ if (this_image() == 1) then
+ caf(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)[1] &
+ = b(i:i_e:i_s*i_sgn1, j:j_e:j_s*i_sgn2)
+ end if
+ sync all
+
+ if (this_image() == num_images()) then
+ if (any (a /= caf)) then
+ print '(*(g0))', "bounds: ", lb1,":",n+lb1-1,", ", &
+ lb2,":",m+lb2-1
+ print '(*(g0))', "section: ", i,":",i_e,":",i_s*i_sgn1, &
+ ", ", j,":",j_e,":",j_s*i_sgn2
+ print *, i
+ print *, a
+ print *, caf
+ print *, a-caf
+ call abort()
+ endif
+ end if
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+ end do
+end subroutine three
+end