Patchwork [Fortran] PR 18918 - implement coarray's IMAGE_INDEX for nonconstant bounds

login
register
mail settings
Submitter Tobias Burnus
Date April 16, 2011, 8:25 p.m.
Message ID <4DA9FB2F.3030002@net-b.de>
Download mbox | patch
Permalink /patch/91498/
State New
Headers show

Comments

Tobias Burnus - April 16, 2011, 8:25 p.m.
The attached patch implements IMAGE_INDEX(COARRAY, SUB) for nonconstant 
bounds; the patch (and the test case) work both with -fcoarray=single 
and with -fcoarray=lib (with any number of images - I tried up to 21).

Note: If the image index would exceed the number of images, 0 is 
returned. Additionally, there are also no other restrictions to the used 
values of SUB. Thus, I had to add an additional check for whether the 
cobounds are exceeded; in that case also 0 is returned.

In simplify.c, currently an error is returned if the cobounds are 
exceeded. One should probably downgrade those to warnings.  
(Nevertheless, if this happens for constant cobounds and constant SUB, 
the algorithm has a problem.)

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

Tobias

PS: In terms of cobounds intrinsics, only THIS_IMAGE(coarray) remains to 
be fixed. Currently, it always returns LCOBOUND(coarray) which is only 
valid for num_images() == 1.
Mikael Morin - April 17, 2011, 10:23 p.m.
On Saturday 16 April 2011 22:25:19 Tobias Burnus wrote:
> In simplify.c, currently an error is returned if the cobounds are
> exceeded. One should probably downgrade those to warnings.
OK with that change.
As far as I know, it is (weird but) valid to use the image_index result for 
something completely unrelated to image indexing (thus not involving any sort 
of invalid coarray access). Then we should not prevent compilation, and return 
zero as mandated by the standard.

Thanks
Mikael

Patch

2011-04-16  Tobias Burnus  <burnus@net-b.de>

	PR fortran/18918
	* iresolve.c (gfc_resolve_image_index): Set ts.type.
	* simplify.c (gfc_simplify_image_index): Don't abort if the bounds
	are not known at compile time and handle -fcoarray=lib.
	* trans-intrinsics.c (gfc_conv_intrinsic_function): Handle
	IMAGE_INDEX.
	(conv_intrinsic_cobound): Fix comment typo.
	(trans_this_image): New function.
	* trans-array.c (gfc_unlikely): Move to trans.c.
	* trans.c (gfc_unlikely): Function moved from trans-array.c.
	(gfc_trans_runtime_check): Use it.
	* trans-io.c (gfc_trans_io_runtime_check): Ditto.
	* trans.h (gfc_unlikely): Add prototype.

2011-04-16  Tobias Burnus  <burnus@net-b.de>

	PR fortran/18918
	* gfortran.dg/coarray_16.f90: New.

diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 5042db3..24c9f76 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -2547,9 +2547,10 @@  void
 gfc_resolve_image_index (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED,
 			 gfc_expr *sub ATTRIBUTE_UNUSED)
 {
-  static char this_image[] = "__image_index";
+  static char image_index[] = "__image_index";
+  f->ts.type = BT_INTEGER;
   f->ts.kind = gfc_default_integer_kind;
-  f->value.function.name = this_image;
+  f->value.function.name = image_index;
 }
 
 
diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c
index abc3383..b744a21 100644
--- a/gcc/fortran/simplify.c
+++ b/gcc/fortran/simplify.c
@@ -6189,7 +6189,7 @@  gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
   int d;
 
   if (!is_constant_array_expr (sub))
-    goto not_implemented; /* return NULL;*/
+    return NULL;
 
   /* Follow any component references.  */
   as = coarray->symtree->n.sym->as;
@@ -6198,7 +6198,7 @@  gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
       as = ref->u.ar.as;
 
   if (as->type == AS_DEFERRED)
-    goto not_implemented; /* return NULL;*/
+    return NULL;
 
   /* "valid sequence of cosubscripts" are required; thus, return 0 unless
      the cosubscript addresses the first image.  */
@@ -6221,7 +6221,7 @@  gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
       ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
 				     NULL, true);
       if (ca_bound == NULL)
-	goto not_implemented; /* return NULL */
+	return NULL;
 
       if (ca_bound == &gfc_bad_expr)
 	return ca_bound;
@@ -6285,6 +6285,10 @@  gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
       return &gfc_bad_expr;
     }
 
+
+  if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && !first_image)
+    return NULL;
+
   result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
 				  &gfc_current_locus);
   if (first_image)
@@ -6293,11 +6297,6 @@  gfc_simplify_image_index (gfc_expr *coarray, gfc_expr *sub)
     mpz_set_si (result->value.integer, 0);
 
   return result;
-
-not_implemented:
-  gfc_error ("Not yet implemented: IMAGE_INDEX for coarray with non-constant "
-	     "cobounds at %L", &coarray->where);
-  return &gfc_bad_expr;
 }
 
 
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 638234e..5293fec 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -4111,21 +4111,6 @@  gfc_conv_descriptor_cosize (tree desc, int rank, int corank)
 }
 
 
-/* Helper function for marking a boolean expression tree as unlikely.  */
-
-static tree
-gfc_unlikely (tree cond)
-{
-  tree tmp;
-
-  cond = fold_convert (long_integer_type_node, cond);
-  tmp = build_zero_cst (long_integer_type_node);
-  cond = build_call_expr_loc (input_location,
-			      built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
-  cond = fold_convert (boolean_type_node, cond);
-  return cond;
-}
-
 /* Fills in an array descriptor, and returns the size of the array.
    The size will be a simple_val, ie a variable or a constant.  Also
    calculates the offset of the base.  The pointer argument overflow,
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index bb9d7e1..aec670d 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -921,6 +921,7 @@  gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
   se->expr = fold_convert (type, res);
 }
 
+
 static void
 trans_this_image (gfc_se * se, gfc_expr *expr ATTRIBUTE_UNUSED)
 {
@@ -928,6 +929,133 @@  trans_this_image (gfc_se * se, gfc_expr *expr ATTRIBUTE_UNUSED)
   se->expr = gfort_gvar_caf_this_image;
 }
 
+
+static void
+trans_image_index (gfc_se * se, gfc_expr *expr)
+{
+  tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc,
+       tmp, invalid_bound;
+  gfc_se argse, subse;
+  gfc_ss *ss, *subss;
+  int rank, corank, codim;
+
+  type = gfc_get_int_type (gfc_default_integer_kind);
+  corank = gfc_get_corank (expr->value.function.actual->expr);
+  rank = expr->value.function.actual->expr->rank;
+
+  /* Obtain the descriptor of the COARRAY.  */
+  gfc_init_se (&argse, NULL);
+  ss = gfc_walk_expr (expr->value.function.actual->expr);
+  gcc_assert (ss != gfc_ss_terminator);
+  ss->data.info.codimen = corank;
+  gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
+  gfc_add_block_to_block (&se->pre, &argse.pre);
+  gfc_add_block_to_block (&se->post, &argse.post);
+  desc = argse.expr;
+
+  /* Obtain a handle to the SUB argument.  */
+  gfc_init_se (&subse, NULL);
+  subss = gfc_walk_expr (expr->value.function.actual->next->expr);
+  gcc_assert (subss != gfc_ss_terminator);
+  gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr,
+			    subss);
+  gfc_add_block_to_block (&se->pre, &subse.pre);
+  gfc_add_block_to_block (&se->post, &subse.post);
+  subdesc = build_fold_indirect_ref_loc (input_location,
+			gfc_conv_descriptor_data_get (subse.expr));
+
+  /* Fortran 2008 does not require that the values remain in the cobounds,
+     thus we need explicitly check this - and return 0 if they are exceeded.  */
+
+  lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
+  tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
+  invalid_bound = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+				 fold_convert (gfc_array_index_type, tmp),
+				 lbound);
+
+  for (codim = corank + rank - 2; codim >= rank; codim--)
+    {
+      lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
+      ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
+      tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
+      cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
+			      fold_convert (gfc_array_index_type, tmp),
+			      lbound);
+      invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+				       boolean_type_node, invalid_bound, cond);
+      cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
+			      fold_convert (gfc_array_index_type, tmp),
+			      ubound);
+      invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+				       boolean_type_node, invalid_bound, cond);
+    }
+
+  invalid_bound = gfc_unlikely (invalid_bound);
+
+
+  /* See Fortran 2008, C.10 for the following algorithm.  */
+
+  /* coindex = sub(corank) - lcobound(n).  */
+  coindex = fold_convert (gfc_array_index_type,
+			  gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
+					       NULL));
+  lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
+  coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+			     fold_convert (gfc_array_index_type, coindex),
+			     lbound);
+
+  for (codim = corank + rank - 2; codim >= rank; codim--)
+    {
+      tree extent, ubound;
+
+      /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim).  */
+      lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
+      ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
+      extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+
+      /* coindex *= extent.  */
+      coindex = fold_build2_loc (input_location, MULT_EXPR,
+				 gfc_array_index_type, coindex, extent);
+
+      /* coindex += sub(codim).  */
+      tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
+      coindex = fold_build2_loc (input_location, PLUS_EXPR,
+				 gfc_array_index_type, coindex,
+				 fold_convert (gfc_array_index_type, tmp));
+
+      /* coindex -= lbound(codim).  */
+      lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
+      coindex = fold_build2_loc (input_location, MINUS_EXPR,
+				 gfc_array_index_type, coindex, lbound);
+    }
+
+  coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
+			     fold_convert(type, coindex),
+			     build_int_cst (type, 1));
+
+  /* Return 0 if "coindex" exceeds num_images().  */
+
+  if (gfc_option.coarray == GFC_FCOARRAY_SINGLE)
+    num_images = build_int_cst (type, 1);
+  else
+    {
+      gfc_init_coarray_decl ();
+      num_images = gfort_gvar_caf_num_images;
+    }
+
+  tmp = gfc_create_var (type, NULL);
+  gfc_add_modify (&se->pre, tmp, coindex);
+
+  cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp,
+			  num_images);
+  cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
+			  cond,
+			  fold_convert (boolean_type_node, invalid_bound));
+  se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
+			      build_int_cst (type, 0), tmp);
+}
+
+
 static void
 trans_num_images (gfc_se * se)
 {
@@ -1233,7 +1361,7 @@  conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
 	   ceiling (real (num_images ()) / real (size)) - 1
 	 = (num_images () + size - 1) / size - 1
 	 = (num_images - 1) / size(),
-         where size is the product of the extend of all but the last
+         where size is the product of the extent of all but the last
 	 codimension.  */
 
       if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && corank > 1)
@@ -6312,6 +6440,10 @@  gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
 	trans_this_image (se, expr);
       break;
 
+    case GFC_ISYM_IMAGE_INDEX:
+      trans_image_index (se, expr);
+      break;
+
     case GFC_ISYM_NUM_IMAGES:
       trans_num_images (se);
       break;
diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index f6a783f..883ec5c 100644
--- a/gcc/fortran/trans-io.c
+++ b/gcc/fortran/trans-io.c
@@ -267,13 +267,7 @@  gfc_trans_io_runtime_check (tree cond, tree var, int error_code,
     }
   else
     {
-      /* Tell the compiler that this isn't likely.  */
-      cond = fold_convert (long_integer_type_node, cond);
-      tmp = build_int_cst (long_integer_type_node, 0);
-      cond = build_call_expr_loc (input_location,
-			      built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
-      cond = fold_convert (boolean_type_node, cond);
-
+      cond = gfc_unlikely (cond);
       tmp = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location));
       gfc_add_expr_to_block (pblock, tmp);
     }
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index 27a352a..9786d97 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -505,11 +505,7 @@  gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock,
       else
 	cond = fold_convert (long_integer_type_node, cond);
 
-      tmp = build_int_cst (long_integer_type_node, 0);
-      cond = build_call_expr_loc (where->lb->location,
-			      built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
-      cond = fold_convert (boolean_type_node, cond);
-
+      cond = gfc_unlikely (cond);
       tmp = fold_build3_loc (where->lb->location, COND_EXPR, void_type_node,
 			     cond, body,
 			     build_empty_stmt (where->lb->location));
@@ -1565,3 +1561,19 @@  gfc_finish_wrapped_block (gfc_wrapped_block* block)
 
   return result;
 }
+
+
+/* Helper function for marking a boolean expression tree as unlikely.  */
+
+tree
+gfc_unlikely (tree cond)
+{
+  tree tmp;
+
+  cond = fold_convert (long_integer_type_node, cond);
+  tmp = build_zero_cst (long_integer_type_node);
+  cond = build_call_expr_loc (input_location,
+			      built_in_decls[BUILT_IN_EXPECT], 2, cond, tmp);
+  cond = fold_convert (boolean_type_node, cond);
+  return cond;
+}
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 543ad52..6a2e4f5 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -512,6 +512,9 @@  void gfc_generate_constructors (void);
 /* Get the string length of an array constructor.  */
 bool get_array_ctor_strlen (stmtblock_t *, gfc_constructor_base, tree *);
 
+/* Mark a condition as unlikely.  */
+tree gfc_unlikely (tree);
+
 /* Generate a runtime error call.  */
 tree gfc_trans_runtime_error (bool, locus*, const char*, ...);
 
--- /dev/null	2011-04-16 08:01:23.231890280 +0200
+++ gcc/gcc/testsuite/gfortran.dg/coarray_16.f90	2011-04-16 21:41:32.000000000 +0200
@@ -0,0 +1,100 @@ 
+! { dg-do run }
+! { dg-options "-fcoarray=single" }
+!
+! Run-time test for IMAGE_INDEX with cobounds only known at
+! the compile time, suitable for any number of NUM_IMAGES()
+! For compile-time cobounds, the -fcoarray=lib version still
+! needs to run-time evalulation if image_index returns > 1
+! as image_index is 0 if the index would exceed num_images().
+!
+! Please set num_images() to >= 13, if possible.
+!
+! PR fortran/18918
+!
+
+program test_image_index
+implicit none
+integer :: index1, index2, index3
+logical :: one
+
+integer, allocatable :: a(:)[:,:,:], b(:)[:,:], c(:,:)[:]
+integer, save :: d(2)[-1:3, *]
+integer, save :: e(2)[-1:-1, 3:*]
+
+one = num_images() == 1
+
+allocate(a(1)[3:3, -4:-3, 88:*])
+allocate(b(2)[-1:0,0:*])
+allocate(c(3,3)[*])
+
+index1 = image_index(a, [3, -4, 88] )
+index2 = image_index(b, [-1, 0] )
+index3 = image_index(c, [1] )
+if (index1 /= 1 .or. index2 /= 1 .or. index3 /= 1) call abort()
+
+
+index1 = image_index(a, [3, -3, 88] )
+index2 = image_index(b, [0, 0] )
+index3 = image_index(c, [2] )
+
+if (one .and. (index1 /= 0 .or. index2 /= 0 .or. index3 /= 0)) &
+  call abort()
+if (.not. one .and. (index1 /= 2 .or. index2 /= 2 .or. index3 /= 2)) &
+  call abort()
+
+
+index1 = image_index(d, [-1, 1] )
+index2 = image_index(d, [0, 1] )
+
+if (one .and. (index1 /= 1 .or. index2 /= 0)) &
+  call abort()
+if (.not. one .and. (index1 /= 1 .or. index2 /= 2)) &
+  call abort()
+
+index1 = image_index(e, [-1, 3] )
+index2 = image_index(e, [-1, 4] )
+
+if (one .and. (index1 /= 1 .or. index2 /= 0)) &
+  call abort()
+if (.not. one .and. (index1 /= 1 .or. index2 /= 2)) &
+  call abort()
+
+call test(1, a,b,c)
+
+! The following test is in honour of the F2008 standard:
+deallocate(a)
+allocate(a (10) [10, 0:9, 0:*])
+
+index1 = image_index(a, [1, 0, 0] )
+index2 = image_index(a, [3, 1, 2] )  ! = 213, yeah!
+index3 = image_index(a, [3, 1, 0] )  ! = 13
+
+if (num_images() < 13 .and. (index1 /= 1 .or. index2 /= 0 .or. index3 /= 0)) &
+  call abort()
+if (num_images() >= 213 .and. (index1 /= 1 .or. index2 /= 213 .or. index3 /= 13)) &
+  call abort()
+if (num_images() >= 13 .and. (index1 /= 1 .or. index2 /= 0 .or. index3 /= 13)) &
+  call abort()
+
+
+contains
+subroutine test(n, a, b, c)
+  integer :: n
+  integer :: a(1)[3*n:3*n, -4*n:-3*n, 88*n:*], b(2)[-1*n:0*n,0*n:*], c(3*n,3*n)[*]
+
+  index1 = image_index(a, [3, -4, 88] )
+  index2 = image_index(b, [-1, 0] )
+  index3 = image_index(c, [1] )
+  if (index1 /= 1 .or. index2 /= 1 .or. index3 /= 1) call abort()
+
+
+  index1 = image_index(a, [3, -3, 88] )
+  index2 = image_index(b, [0, 0] )
+  index3 = image_index(c, [2] )
+
+  if (one .and. (index1 /= 0 .or. index2 /= 0 .or. index3 /= 0)) &
+    call abort()
+  if (.not. one .and. (index1 /= 2 .or. index2 /= 2 .or. index3 /= 2)) &
+    call abort()
+end subroutine test
+end program test_image_index