RFC patch: Dependency/alias analysis wir same-image coarray access

[Tobias Burnus <burnus at net-b dot de>]

Hi all,

it turned out that one has to be careful with the coarray assignment to 
the same variable such as:
  a(:)[this_image()] = a(:)
Seemingly, MPI_Get/MPI_Put do not like that at all; for that case (and 
this_image() == requested image index), one can escape by using memmove, 
which handles overlaps. As this primarily hinges on this_image() == 
image index, I think it can be handled directly in the library.

However, for code like
  a(n:1:-1)[1] = a(1:n:1)
one needs in general a temporary.

RFC questions:
a) Does it make sense to pass this information to the library? Or should 
the library check itself whether there is an overlap, requiring the use 
of a temporary.

b) What information should the compiler provide?
- It can test whether two variables / derived-type components used in 
expressions may alias or not. (Works reliable, except that for pointers 
one errs on the side of aliasing).
- It can additionally check whether array references are overlapping, 
i.e. a(1:4) and a(6:5) refer to the same variable but do not overlap - 
when that's detectable at compile time; same for a(1::2) and a(2::2).
- It can tell whether the the overlap is identical (a(1:2) = a(1:2)), 
possible without temporary when assigning up or downward (e.g. a(1:5) = 
a(2:6) vs. a(2:6) = a(1:5)).


Thus, the question is whether the library should take care of all alias 
analysis itself or whether the compiler should provide additional 
information; and if the latter, what properties should be passed to the 
library. (The check whether the passed image index refers to the current 
image or not, is in any case responsibility of the library.)

Comments, suggestions?

The attached patch sets the variable to "true", if walking in array 
order, could lead to the requirement for a temporary.
 That is: It is false for identical sections "A(:)[i]=A(:)", for 
nonoverlapping ones "A(1:5)[i]=A(6:10)" but also for forward walking 
ones such as "A(1:3)[i] = A(3:5)". But it is true for backward access 
such as "A(3:1:-1)[i] = A(5:3:-1)" - and when it is not determinable at 
compile time (pointer aliasing, unknown array indexes etc.) Does that 
version make sense?

Note: The .texi wording would have to be tuned. Additionally, be careful 
with applying the patch as the line numbers are off and due to diff -U0, 
"patch" won't be able to correct this.

Tobias

 b/gcc/fortran/gfortran.texi     |   13 ++++++++++---
 b/gcc/fortran/trans-decl.c      |    2 +-
 b/gcc/fortran/trans-intrinsic.c |    1 +
 b/libgfortran/caf/libcaf.h      |    2 +-
 libgfortran/caf/single.c        |    3 ++-
 5 files changed, 15 insertions(+), 6 deletions(-)

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 3063fea..c346e6e 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -3356 +3356 @@ gfc_build_builtin_function_decls (void)
-	get_identifier (PREFIX("caf_get")), ".R.RRRW", void_type_node, 8,
+	get_identifier (PREFIX("caf_get")), ".R.RRRW", void_type_node, 9,
@@ -3358 +3358,2 @@ gfc_build_builtin_function_decls (void)
-	pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node);
+	pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node,
+	boolean_type_node);
@@ -3361 +3362 @@ gfc_build_builtin_function_decls (void)
-	get_identifier (PREFIX("caf_send")), ".R.RRRR", void_type_node, 8,
+	get_identifier (PREFIX("caf_send")), ".R.RRRR", void_type_node, 9,
@@ -3363 +3364,2 @@ gfc_build_builtin_function_decls (void)
-	pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node);
+	pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node,
+	boolean_type_node);
@@ -3367 +3369 @@ gfc_build_builtin_function_decls (void)
-	12, pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
+	13, pvoid_type_node, size_type_node, integer_type_node, pvoid_type_node,
@@ -3369 +3371,2 @@ gfc_build_builtin_function_decls (void)
-	pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node);
+	pvoid_type_node, pvoid_type_node, integer_type_node, integer_type_node,
+	boolean_type_node);
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index fd3c46a..6740de6 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -42,0 +43 @@ along with GCC; see the file COPYING3.  If not see
+#include "dependency.h"	/* For CAF array alias analysis.  */
@@ -1227 +1090,2 @@ static void
-gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind)
+gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
+			    tree may_overlap)
@@ -1331,2 +1195,6 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind)
  image_index = caf_get_image_index (&se->pre, array_expr, caf_decl);
  get_caf_token_offset (&token, &offset, caf_decl, argse.expr, array_expr);
+
+  /* No overlap possible as we have generated a temporary.  */
+  if (lhs == NULL_TREE)
+    may_overlap = boolean_false_node;
@@ -1334 +1202 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind)
-  tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get, 8,
+  tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_get, 9,
@@ -1336 +1204 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind)
-			     dst_var, kind, lhs_kind);
+			     dst_var, kind, lhs_kind, may_overlap);
@@ -1355,0 +1224 @@ conv_caf_send (gfc_code *code) {
+  tree may_overlap;
@@ -1362,0 +1232,2 @@ conv_caf_send (gfc_code *code) {
+  may_overlap = gfc_check_dependency (lhs_expr, rhs_expr, false) == 0
+		? boolean_false_node : boolean_true_node;
@@ -1416 +1287,2 @@ conv_caf_send (gfc_code *code) {
-      gfc_conv_intrinsic_caf_get (&rhs_se, rhs_expr, lhs_se.expr, lhs_kind);
+      gfc_conv_intrinsic_caf_get (&rhs_se, rhs_expr, lhs_se.expr, lhs_kind,
+				  may_overlap);
@@ -1483 +1355 @@ conv_caf_send (gfc_code *code) {
-    tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 8, token,
+    tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 9, token,
@@ -1485 +1357 @@ conv_caf_send (gfc_code *code) {
-			     rhs_se.expr, lhs_kind, rhs_kind);
+			     rhs_se.expr, lhs_kind, rhs_kind, may_overlap);
@@ -1499 +1371,2 @@ conv_caf_send (gfc_code *code) {
-				 rhs_se.expr, rhs_vec, lhs_kind, rhs_kind);
+				 rhs_se.expr, rhs_vec, lhs_kind, rhs_kind,
+				 may_overlap);
@@ -5911 +5784 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
-	  the size from the descriptor.  */
+	 the size from the descriptor.  */
@@ -7524 +7397 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
-      gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, NULL_TREE);
+      gfc_conv_intrinsic_caf_get (se, expr, NULL_TREE, NULL_TREE, NULL_TREE);
diff --git a/libgfortran/caf/libcaf.h b/libgfortran/caf/libcaf.h
index 85d6811..0f3398a 100644
--- a/libgfortran/caf/libcaf.h
+++ b/libgfortran/caf/libcaf.h
@@ -117 +117 @@ void _gfortran_caf_get (caf_token_t, size_t, int, gfc_descriptor_t *,
-                        caf_vector_t *, gfc_descriptor_t *, int, int);
+                        caf_vector_t *, gfc_descriptor_t *, int, int, bool);
@@ -119 +119 @@ void _gfortran_caf_send (caf_token_t, size_t, int, gfc_descriptor_t *,
-			 caf_vector_t *, gfc_descriptor_t *, int, int);
+			 caf_vector_t *, gfc_descriptor_t *, int, int, bool);
@@ -122 +122 @@ void _gfortran_caf_sendget (caf_token_t, size_t, int, gfc_descriptor_t *,
-			    gfc_descriptor_t *, caf_vector_t *, int, int);
+			    gfc_descriptor_t *, caf_vector_t *, int, int, bool);
diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c
index 990953a..8fd1589 100644
--- a/libgfortran/caf/single.c
+++ b/libgfortran/caf/single.c
@@ -536 +536,2 @@ _gfortran_caf_get (caf_token_t token, size_t offset,
-		   gfc_descriptor_t *dest, int src_kind, int dst_kind)
+		   gfc_descriptor_t *dest, int src_kind, int dst_kind,
+		   bool may_overlap)
@@ -586,0 +588,76 @@ _gfortran_caf_get (caf_token_t token, size_t offset,
+  if (may_overlap)
+    {
+      ptrdiff_t array_offset_sr, array_offset_dst;
+      void *tmp = malloc (size*src_size);
+
+      array_offset_dst = 0;
+      for (i = 0; i < size; i++)
+	{
+	  ptrdiff_t array_offset_sr = 0;
+	  ptrdiff_t stride = 1;
+	  ptrdiff_t 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) * src->dim[rank-1]._stride;
+	  void *sr = (void *)((char *) TOKEN (token) + offset
+			  + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
+          memcpy ((void *) ((char *) tmp + array_offset_dst), sr, src_size);
+          array_offset_dst += src_size;
+	}
+
+      array_offset_sr = 0;
+      for (i = 0; i < size; i++)
+	{
+	  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;
+	  void *dst = dest->base_addr
+		      + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest);
+          void *sr = tmp + array_offset_sr;
+
+	  if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
+	      && dst_kind == src_kind)
+	    {
+	      memmove (dst, sr, dst_size > src_size ? src_size : dst_size);
+	      if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER
+	          && dst_size > src_size)
+		{
+		  if (dst_kind == 1)
+		    memset ((void*)(char*) dst + src_size, ' ',
+			    dst_size-src_size);
+		  else /* dst_kind == 4.  */
+		    for (k = src_size/4; k < dst_size/4; k++)
+		      ((int32_t*) dst)[k] = (int32_t) ' ';
+		}
+	    }
+	  else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
+	    assign_char1_from_char4 (dst_size, src_size, dst, sr);
+	  else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
+	    assign_char4_from_char1 (dst_size, src_size, dst, sr);
+	  else
+	    convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
+			  sr, GFC_DESCRIPTOR_TYPE (src), src_kind);
+          array_offset_sr += src_size;
+	}
+
+      free (tmp);
+      return;
+    }
+
@@ -649 +726,2 @@ _gfortran_caf_send (caf_token_t token, size_t offset,
-		    gfc_descriptor_t *src, int dst_kind, int src_kind)
+		    gfc_descriptor_t *src, int dst_kind, int src_kind,
+		    bool may_overlap)
@@ -699,0 +778,85 @@ _gfortran_caf_send (caf_token_t token, size_t offset,
+  if (may_overlap)
+    {
+      ptrdiff_t array_offset_sr, array_offset_dst;
+      void *tmp;
+
+      if (GFC_DESCRIPTOR_RANK (src) == 0)
+	{
+	  tmp = malloc (src_size);
+	  memcpy (tmp, GFC_DESCRIPTOR_DATA (src), src_size);
+	}
+      else
+	{
+	  tmp = malloc (size*src_size);
+	  array_offset_dst = 0;
+	  for (i = 0; i < size; i++)
+	    {
+	      ptrdiff_t array_offset_sr = 0;
+	      ptrdiff_t stride = 1;
+	      ptrdiff_t 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) * src->dim[rank-1]._stride;
+	      void *sr = (void *) ((char *) src->base_addr
+				   + array_offset_sr*GFC_DESCRIPTOR_SIZE (src));
+	      memcpy ((void *) ((char *) tmp + array_offset_dst), sr, src_size);
+	      array_offset_dst += src_size;
+	    }
+	}
+
+      array_offset_sr = 0;
+      for (i = 0; i < size; i++)
+	{
+	  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;
+	  void *dst = (void *)((char *) TOKEN (token) + offset
+		      + array_offset_dst*GFC_DESCRIPTOR_SIZE (dest));
+          void *sr = tmp + array_offset_sr;
+	  if (GFC_DESCRIPTOR_TYPE (dest) == GFC_DESCRIPTOR_TYPE (src)
+	      && dst_kind == src_kind)
+	    {
+	      memmove (dst, sr,
+		       dst_size > src_size ? src_size : dst_size);
+	      if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER
+		  && dst_size > src_size)
+		{
+		  if (dst_kind == 1)
+		    memset ((void*)(char*) dst + src_size, ' ',
+			    dst_size-src_size);
+		  else /* dst_kind == 4.  */
+		    for (k = src_size/4; k < dst_size/4; k++)
+		      ((int32_t*) dst)[k] = (int32_t) ' ';
+		}
+	    }
+	  else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER && dst_kind == 1)
+	    assign_char1_from_char4 (dst_size, src_size, dst, sr);
+	  else if (GFC_DESCRIPTOR_TYPE (dest) == BT_CHARACTER)
+	    assign_char4_from_char1 (dst_size, src_size, dst, sr);
+	  else
+	    convert_type (dst, GFC_DESCRIPTOR_TYPE (dest), dst_kind,
+			  sr, GFC_DESCRIPTOR_TYPE (src), src_kind);
+          if (GFC_DESCRIPTOR_RANK (src))
+	    array_offset_sr += src_size;
+	}
+      free (tmp);
+      return;
+    }
+
@@ -772 +935 @@ _gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset,
-		       int dst_kind, int src_kind)
+		       int dst_kind, int src_kind, bool may_overlap)
@@ -780 +943 @@ _gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset,
-		      src, dst_kind, src_kind);
+		      src, dst_kind, src_kind, may_overlap);
diff --git a/gcc/fortran/gfortran.texi b/gcc/fortran/gfortran.texi
index 0ce7226..88e37cf 100644
--- a/gcc/fortran/gfortran.texi
+++ b/gcc/fortran/gfortran.texi
@@ -3448,7 +3448,7 @@ to a remote image identified by the image_index.
 @item @emph{Syntax}:
 @code{void _gfortran_caf_send (caf_token_t token, size_t offset,
 int image_index, gfc_descriptor_t *dest, caf_vector_t *dst_vector,
-gfc_descriptor_t *src, int dst_kind, int src_kind)}
+gfc_descriptor_t *src, int dst_kind, int src_kind, bool may_overlap)}
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
@@ -3466,6 +3466,9 @@ triplet of the dest argument.
 transferred to the remote image
 @item @var{dst_kind} @tab Kind of the destination argument
 @item @var{src_kind} @tab Kind of the source argument
+@item @var{may_overlap} @tab If true and @var{image_index} refers to the
+current image, the left-hand-side and right-hand-side variables may
+(partially or fully) overlap.
 @end multitable
 
 @item @emph{NOTES}
@@ -3490,7 +3493,7 @@ image identified by the image_index.
 @item @emph{Syntax}:
 @code{void _gfortran_caf_get_desc (caf_token_t token, size_t offset,
 int image_index, gfc_descriptor_t *src, caf_vector_t *src_vector,
-gfc_descriptor_t *dest, int src_kind, int dst_kind)}
+gfc_descriptor_t *dest, int src_kind, int dst_kind, bool may_overlap)}
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
@@ -3533,7 +3536,8 @@ dst_image_index.
 @code{void _gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset,
 int dst_image_index, gfc_descriptor_t *dest, caf_vector_t *dst_vector,
 caf_token_t src_token, size_t src_offset, int src_image_index,
-gfc_descriptor_t *src, caf_vector_t *src_vector, int dst_kind, int src_kind)}
+gfc_descriptor_t *src, caf_vector_t *src_vector, int dst_kind, int src_kind,
+bool may_overlap)}
 
 @item @emph{Arguments}:
 @multitable @columnfractions .15 .70
@@ -3559,6 +3563,9 @@ transferred to the remote image.
 be transferred to the remote image
 @item @var{dst_kind} @tab Kind of the destination argument
 @item @var{src_kind} @tab Kind of the source argument
+@item @var{may_overlap} @tab If true and @var{dst_image_index} and
+@var{src_image_index} are the same, the left-hand-side and right-hand-side
+variables may (partially or fully) overlap.
 @end multitable
 
 @item @emph{NOTES}