This is the mail archive of the gcc-patches@gcc.gnu.org mailing list for the GCC project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[Patch, Fortran] -fcoarray=lib: Fix vector subscript handling


As testing by Alessandro revealed, vector subscripts weren't properly handled.

This patch fixes the compiler side (or at least those issues I found). In particular, for expressions ("get") it wrongly passed a NULL pointer, additionally, I used the wrong "ar". For it and for assignments/push ("send", "sendget"), I also used the wrong rank value as one also passes DIMEN_ELEMENT as DIMEN_RANGE.

Build and regtested on x86-64-gnu-linux.
OK for the trunk?

* * *

I still have to add vector subscript support to libcaf_single. I didn't include an -fdump-tree-original test case, but I can add one if there regarded as useful.

Attached is â besides the patch for trans-intrinsic.c â a debuging patch for libcaf_single. I tested it with:
integer :: A(2,3)[*]
A(2,:) = A(1,[1,3,2])[1]
end

integer :: A(2,3)[*]
A(1,[1,3,2])[1] = A(2,:)
end

integer :: A(2,3)[*]
integer :: B(2,3)[*]
A(1,[1,3,2])[1] = B(1,[1,3,2])[1]
end

The output looks like (for the first one):

DEBUG: CAF_GET: 0x7fffb72f71d0
DEBUG: have vector for rank 2 [1]
DEBUG: dim=0: nvec = 0
DEBUG: (1:1:1)
DEBUG: dim=1: nvec = 3
DEBUG: 0: 1
DEBUG: 1: 3
DEBUG: 2: 2

Tobias
2014-12-17  Tobias Burnus  <burnus@net-b.de>

	* trans-intrinsic.c (gfc_conv_intrinsic_caf_get, conv_caf_send):
	Fix vector handling.

diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index 0cce3cb..31cb6c7 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1122,6 +1122,8 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
   res_var = lhs;
   dst_var = lhs;
 
+  vec = null_pointer_node;
+
   gfc_init_se (&argse, NULL);
   if (array_expr->rank == 0)
     {
@@ -1164,10 +1166,12 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
       /* Using gfc_conv_expr_descriptor, we only get the descriptor, but that
          has the wrong type if component references are done.  */
       gfc_add_modify (&argse.pre, gfc_conv_descriptor_dtype (argse.expr),
-                      gfc_get_dtype_rank_type (array_expr->rank, type));
+                      gfc_get_dtype_rank_type (has_vector ? ar2.dimen
+							  : array_expr->rank,
+					       type));
       if (has_vector)
 	{
-	  vec = conv_caf_vector_subscript (&argse.pre, argse.expr, ar);
+	  vec = conv_caf_vector_subscript (&argse.pre, argse.expr, &ar2);
 	  *ar = ar2;
 	}
 
@@ -1195,8 +1199,6 @@ gfc_conv_intrinsic_caf_get (gfc_se *se, gfc_expr *expr, tree lhs, tree lhs_kind,
   if (lhs_kind == NULL_TREE)
     lhs_kind = kind;
 
-  vec = null_pointer_node;
-
   gfc_add_block_to_block (&se->pre, &argse.pre);
   gfc_add_block_to_block (&se->post, &argse.post);
 
@@ -1278,10 +1280,12 @@ conv_caf_send (gfc_code *code) {
       lhs_type = gfc_typenode_for_spec (&lhs_expr->ts);
       tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
       gfc_add_modify (&lhs_se.pre, gfc_conv_descriptor_dtype (tmp),
-                      gfc_get_dtype_rank_type (lhs_expr->rank, lhs_type));
+                      gfc_get_dtype_rank_type (has_vector ? ar2.dimen
+							  : lhs_expr->rank,
+		      lhs_type));
       if (has_vector)
 	{
-	  vec = conv_caf_vector_subscript (&block, lhs_se.expr, ar);
+	  vec = conv_caf_vector_subscript (&block, lhs_se.expr, &ar2);
 	  *ar = ar2;
 	}
     }
@@ -1350,10 +1354,12 @@ conv_caf_send (gfc_code *code) {
       tmp = build_fold_indirect_ref_loc (input_location, rhs_se.expr);
       tmp2 = gfc_typenode_for_spec (&rhs_expr->ts);
       gfc_add_modify (&rhs_se.pre, gfc_conv_descriptor_dtype (tmp),
-                      gfc_get_dtype_rank_type (rhs_expr->rank, tmp2));
+                      gfc_get_dtype_rank_type (has_vector ? ar2.dimen
+							  : rhs_expr->rank,
+		      tmp2));
       if (has_vector)
 	{
-	  rhs_vec = conv_caf_vector_subscript (&block, rhs_se.expr, ar);
+	  rhs_vec = conv_caf_vector_subscript (&block, rhs_se.expr, &ar2);
 	  *ar = ar2;
 	}
     }
diff --git a/libgfortran/caf/single.c b/libgfortran/caf/single.c
index 632d172..2c6d5ae 100644
--- a/libgfortran/caf/single.c
+++ b/libgfortran/caf/single.c
@@ -543,7 +543,7 @@ void
 _gfortran_caf_get (caf_token_t token, size_t offset,
 		   int image_index __attribute__ ((unused)),
 		   gfc_descriptor_t *src,
-		   caf_vector_t *src_vector __attribute__ ((unused)),
+		   caf_vector_t *src_vector,
 		   gfc_descriptor_t *dest, int src_kind, int dst_kind,
 		   bool may_require_tmp)
 {
@@ -551,9 +551,43 @@ _gfortran_caf_get (caf_token_t token, size_t offset,
   size_t i, k, size;
   int j;
   int rank = GFC_DESCRIPTOR_RANK (dest);
+  int src_rank = GFC_DESCRIPTOR_RANK (src);
   size_t src_size = GFC_DESCRIPTOR_SIZE (src);
   size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
 
+  if (src_vector)
+{
+__builtin_printf("DEBUG: CAF_GET: %p\n", src_vector);
+__builtin_printf("DEBUG: have vector for rank %d [%d]\n", src_rank, rank);
+for (j=0; j < src_rank; j++)
+{
+__builtin_printf("DEBUG: dim=%d: nvec = %u\n", j, src_vector[j].nvec);
+if (src_vector[j].nvec == 0)
+  __builtin_printf("DEBUG: (%lu:%lu:%lu)\n",
+                   src_vector[j].u.triplet.lower_bound,
+                   src_vector[j].u.triplet.upper_bound,
+                   src_vector[j].u.triplet.stride);
+for (i=0; i < src_vector[j].nvec; i++)
+switch (src_vector[j].u.v.kind) {
+ case 1:
+    __builtin_printf("DEBUG: %lu: %d\n", i, ((int8_t *)src_vector[j].u.v.vector)[i]);
+    break;
+ case 2:
+    __builtin_printf("DEBUG: %lu: %d\n", i, ((int16_t *)src_vector[j].u.v.vector)[i]);
+    break;
+ case 4:
+    __builtin_printf("DEBUG: %lu: %d\n", i, ((int32_t *)src_vector[j].u.v.vector)[i]);
+    break;
+ case 8:
+    __builtin_printf("DEBUG: %lu: %ld\n", i, (long)((int64_t *)src_vector[j].u.v.vector)[i]);
+    break;
+/* case 16:
+    __builtin_printf("DEBUG: %lu: %ld\n", i, (long)((__int128 *)src_vector[j].u.v.vector)[i]);
+    break;*/
+}
+}
+}
+
   if (rank == 0)
     {
       void *sr = (void *) ((char *) TOKEN (token) + offset);
@@ -744,6 +778,39 @@ _gfortran_caf_send (caf_token_t token, size_t offset,
   size_t src_size = GFC_DESCRIPTOR_SIZE (src);
   size_t dst_size = GFC_DESCRIPTOR_SIZE (dest);
 
+  if (dst_vector)
+{
+__builtin_printf("DEBUG: CAF_SEND: %p\n", dst_vector);
+__builtin_printf("DEBUG: have vector for rank %d\n", rank);
+for (j=0; j < rank; j++)
+{
+__builtin_printf("DEBUG: dim=%d: nvec = %u\n", j, dst_vector[j].nvec);
+if (dst_vector[j].nvec == 0)
+  __builtin_printf("DEBUG: (%lu:%lu:%lu)\n",
+                   dst_vector[j].u.triplet.lower_bound,
+                   dst_vector[j].u.triplet.upper_bound,
+                   dst_vector[j].u.triplet.stride);
+for (i=0; i < dst_vector[j].nvec; i++)
+switch (dst_vector[j].u.v.kind) {
+ case 1:
+    __builtin_printf("DEBUG: %lu: %d\n", i, ((int8_t *)dst_vector[j].u.v.vector)[i]);
+    break;
+ case 2:
+    __builtin_printf("DEBUG: %lu: %d\n", i, ((int16_t *)dst_vector[j].u.v.vector)[i]);
+    break;
+ case 4:
+    __builtin_printf("DEBUG: %lu: %d\n", i, ((int32_t *)dst_vector[j].u.v.vector)[i]);
+    break;
+ case 8:
+    __builtin_printf("DEBUG: %lu: %ld\n", i, (long)((int64_t *)dst_vector[j].u.v.vector)[i]);
+    break;
+/* case 16:
+    __builtin_printf("DEBUG: %lu: %ld\n", i, (long)((__int128 *)dst_vector[j].u.v.vector)[i]);
+    break;*/
+}
+}
+}
+
   if (rank == 0)
     {
       void *dst = (void *) ((char *) TOKEN (token) + offset);
@@ -948,6 +1015,44 @@ _gfortran_caf_sendget (caf_token_t dst_token, size_t dst_offset,
   /* FIXME: Handle vector subscript of 'src_vector'.  */
   /* For a single image, src->base_addr should be the same as src_token + offset
      but to play save, we do it properly.  */
+
+  int src_rank = GFC_DESCRIPTOR_RANK (src);
+  size_t i, k, size;
+  int j;
+  if (src_vector)
+{
+__builtin_printf("DEBUG: CAF_SENDGET: %p / %p\n", dst_vector, src_vector);
+__builtin_printf("DEBUG: have src vector for rank %d\n", src_rank);
+for (j=0; j < src_rank; j++)
+{
+__builtin_printf("DEBUG: dim=%d: nvec = %u\n", j, src_vector[j].nvec);
+if (src_vector[j].nvec == 0)
+  __builtin_printf("DEBUG: (%lu:%lu:%lu)\n",
+                   src_vector[j].u.triplet.lower_bound,
+                   src_vector[j].u.triplet.upper_bound,
+                   src_vector[j].u.triplet.stride);
+for (i=0; i < src_vector[j].nvec; i++)
+switch (src_vector[j].u.v.kind) {
+ case 1:
+    __builtin_printf("DEBUG: %lu: %d\n", i, ((int8_t *)src_vector[j].u.v.vector)[i]);
+    break;
+ case 2:
+    __builtin_printf("DEBUG: %lu: %d\n", i, ((int16_t *)src_vector[j].u.v.vector)[i]);
+    break;
+ case 4:
+    __builtin_printf("DEBUG: %lu: %d\n", i, ((int32_t *)src_vector[j].u.v.vector)[i]);
+    break;
+ case 8:
+    __builtin_printf("DEBUG: %lu: %ld\n", i, (long)((int64_t *)src_vector[j].u.v.vector)[i]);
+    break;
+/* case 16:
+    __builtin_printf("DEBUG: %lu: %ld\n", i, (long)((__int128 *)src_vector[j].u.v.vector)[i]);
+    break;*/
+}
+}
+}
+
+
   void *src_base = GFC_DESCRIPTOR_DATA (src);
   GFC_DESCRIPTOR_DATA (src) = (void *) ((char *) TOKEN (src_token) + src_offset);
   _gfortran_caf_send (dst_token, dst_offset, dst_image_index, dest, dst_vector,

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]