Patchwork [Fortran] Coarray: Pass token for coarray dummies

login
register
mail settings
Submitter Tobias Burnus
Date July 20, 2011, 9:30 p.m.
Message ID <4E274906.2040405@net-b.de>
Download mbox | patch
Permalink /patch/105839/
State New
Headers show

Comments

Tobias Burnus - July 20, 2011, 9:30 p.m.
With -fcoarray=lib, coarrays are identified to the library by a "token". 
Thus, asking for a RHS expression like "caf(2)[4]" means that one 
requests from the library to read 4-bytes from image 4 from the coarray 
identified by "token" starting from an offset of 4-bytes, assuming that 
the array is, e.g., "integer :: caf(10)[*]".

Thus, when one passes a coarray as actual argument to a coarray dummy 
both the offset and the token has to be passed as well. That's what the 
attached patch does for nondescriptor arrays.

Note that  not only "caf" is a coarray but also "caf(2:3)" or "caf(4)" 
or "caf_dt%comp".


For arrays with array descriptor, the "token" will be saved in the 
descriptor; however, that's not yet implemented. Hence, I had to 
implement a fall-back version for passing an array with descriptor to an 
nondescriptor dummy (i.e. passing NULL - as one does for absent optional 
arguments).


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

Tobias
Paul Richard Thomas - July 21, 2011, 11:25 a.m.
Dear Tobias,
>
> Build and regtested on x86-64-linux.
> OK for the trunk?

OK for trunk.  The machinery is well used for other purposes and I do
not see any problem with your implementation.

We are making increasing use of scan-tree-dump-times in the tests.  I
wonder if this is well advised?  I have been hit in the past by
subsequent patches affecting these tests even though the relevant
patch is working fine.  That said, it will flag up the changes if and
when array descriptor reform is finally done.

Thanks for the patch

Paul
Tobias Burnus - July 21, 2011, 12:09 p.m.
Dear Paul,

On 07/21/2011 01:25 PM, Paul Richard Thomas wrote:
> We are making increasing use of scan-tree-dump-times in the tests.  I
> wonder if this is well advised?

I think it is the only way to make sure that things work as advised - 
the other possibility is to look at the assembler output: scan-assembler 
and scan-assembler-not.

Doing things just on the basis whether it compiles is not as reliable - 
and run tests are much more expensive. Regarding the latter: I think it 
would be useful to have a run-once test mode. This mode is useful for 
testing the library and some correctness issues without being as heavy 
as a full blown run with different optimization options.

> I have been hit in the past by subsequent patches affecting these tests even though the relevant patch is working fine. That said, it will flag up the changes if and
> when array descriptor reform is finally done.

I concur that there are issues such as platform dependence (I wouldn't 
be surprised about such failures for this patch) and it makes it also 
more difficult if one does more invasive patches, which affect many test 
cases without changing their result.

But I do not see any good alternative. Looking at dumps while writing 
patches has often found problems, which exist but do not show up at run 
time. For instance, the initial patch (w/o the se->wants_pointer part of 
the patch) didn't simplify the offset to 0 if one passed the same 
object. And similar issues can be introduced when working on other 
patches - and only such scan tests can find them.

Thanks for reviewing the patch, which has been committed as Rev. 176562.

Tobias

Patch

2011-07-20  Tobias Burnus  <burnus@net-b.de>

	* check.c (gfc_check_present): Allow coarrays.
	* trans-array.c (gfc_conv_array_ref): Avoid casting
	when a pointer is wanted.
	* trans-decl.c (create_function_arglist): For -fcoarray=lib,
	handle hidden token and offset arguments for nondescriptor
	coarrays.
	* trans-expr.c (get_tree_for_caf_expr): New function.
	(gfc_conv_procedure_call): For -fcoarray=lib pass the
	token and offset for nondescriptor coarray dummies.
	* trans.h (lang_type): Add caf_offset tree.
	(GFC_TYPE_ARRAY_CAF_OFFSET): New macro.

2011-07-20  Tobias Burnus  <burnus@net-b.de>

	* gfortran.dg/coarray_lib_token_1.f90: New.


diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index 79e1c95..a95865b 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -2895,7 +2895,9 @@  gfc_check_present (gfc_expr *a)
 
   if (a->ref != NULL
       && !(a->ref->next == NULL && a->ref->type == REF_ARRAY
-	   && a->ref->u.ar.type == AR_FULL))
+	   && (a->ref->u.ar.type == AR_FULL
+	       || (a->ref->u.ar.type == AR_ELEMENT
+		   && a->ref->u.ar.as->rank == 0))))
     {
       gfc_error ("'%s' argument of '%s' intrinsic at %L must not be a "
 		 "subobject of '%s'", gfc_current_intrinsic_arg[0]->name,
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 4ec892b..9caa17f 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -2631,10 +2631,11 @@  gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
 	  if (GFC_ARRAY_TYPE_P (TREE_TYPE (se->expr))
 	      && TREE_CODE (TREE_TYPE (se->expr)) == POINTER_TYPE)
 	    se->expr = build_fold_indirect_ref_loc (input_location, se->expr);
-	
+
 	  /* Use the actual tree type and not the wrapped coarray. */
-	  se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
-				   se->expr);
+	  if (!se->want_pointer)
+	    se->expr = fold_convert (TYPE_MAIN_VARIANT (TREE_TYPE (se->expr)),
+				     se->expr);
 	}
 
       return;
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 65a8efa..12c5262 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -2104,6 +2104,48 @@  create_function_arglist (gfc_symbol * sym)
 
       f->sym->backend_decl = parm;
 
+      /* Coarrays which do not use a descriptor pass with -fcoarray=lib the
+	 token and the offset as hidden arguments.  */
+      if (f->sym->attr.codimension
+	  && gfc_option.coarray == GFC_FCOARRAY_LIB
+	  && !f->sym->attr.allocatable
+	  && f->sym->as->type != AS_ASSUMED_SHAPE)
+	{
+	  tree caf_type;
+	  tree token;
+	  tree offset;
+
+	  gcc_assert (f->sym->backend_decl != NULL_TREE
+		      && !sym->attr.is_bind_c);
+	  caf_type = TREE_TYPE (f->sym->backend_decl);
+
+	  gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) == NULL_TREE);
+	  token = build_decl (input_location, PARM_DECL,
+			      create_tmp_var_name ("caf_token"),
+			      build_qualified_type (pvoid_type_node,
+						    TYPE_QUAL_RESTRICT));
+	  GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) = token;
+	  DECL_CONTEXT (token) = fndecl;
+	  DECL_ARTIFICIAL (token) = 1;
+	  DECL_ARG_TYPE (token) = TREE_VALUE (typelist);
+	  TREE_READONLY (token) = 1;
+	  hidden_arglist = chainon (hidden_arglist, token);
+	  gfc_finish_decl (token);
+
+	  gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) == NULL_TREE);
+	  offset = build_decl (input_location, PARM_DECL,
+			       create_tmp_var_name ("caf_offset"),
+			       gfc_array_index_type);
+
+	  GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) = offset;
+	  DECL_CONTEXT (offset) = fndecl;
+	  DECL_ARTIFICIAL (offset) = 1;
+	  DECL_ARG_TYPE (offset) = TREE_VALUE (typelist);
+	  TREE_READONLY (offset) = 1;
+	  hidden_arglist = chainon (hidden_arglist, offset);
+	  gfc_finish_decl (offset);
+	}
+
       arglist = chainon (arglist, parm);
       typelist = TREE_CHAIN (typelist);
     }
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 26d4398..7622910 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -261,6 +261,33 @@  gfc_get_expr_charlen (gfc_expr *e)
 }
 
 
+/* Return for an expression the backend decl of the coarray.  */
+
+static tree
+get_tree_for_caf_expr (gfc_expr *expr)
+{
+   tree caf_decl = NULL_TREE;
+   gfc_ref *ref;
+
+   gcc_assert (expr && expr->expr_type == EXPR_VARIABLE);
+   if (expr->symtree->n.sym->attr.codimension)
+     caf_decl = expr->symtree->n.sym->backend_decl;
+
+   for (ref = expr->ref; ref; ref = ref->next)
+     if (ref->type == REF_COMPONENT)
+       {
+	gfc_component *comp = ref->u.c.component;
+        if (comp->attr.pointer || comp->attr.allocatable)
+	  caf_decl = NULL_TREE;
+	if (comp->attr.codimension)
+	  caf_decl = comp->backend_decl;
+       }
+
+   gcc_assert (caf_decl != NULL_TREE);
+   return caf_decl;
+}
+
+
 /* For each character array constructor subexpression without a ts.u.cl->length,
    replace it by its first element (if there aren't any elements, the length
    should already be set to zero).  */
@@ -2814,6 +2841,7 @@  conv_isocbinding_procedure (gfc_se * se, gfc_symbol * sym,
   return 0;
 }
 
+
 /* Generate code for a procedure call.  Note can return se->post != NULL.
    If se->direct_byref is set then se->expr contains the return parameter.
    Return nonzero, if the call has alternate specifiers.
@@ -3362,6 +3390,59 @@  gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
       if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c)
 	VEC_safe_push (tree, gc, stringargs, parmse.string_length);
 
+      /* For descriptorless coarrays, we pass the token and the offset
+	 as additional arguments.  */
+      if (fsym && fsym->attr.codimension
+	  && gfc_option.coarray == GFC_FCOARRAY_LIB
+	  && !fsym->attr.allocatable && fsym->as->type != AS_ASSUMED_SHAPE
+	  && (e == NULL
+	      || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (get_tree_for_caf_expr (e)))))
+	  /* FIXME: Remove the "||" condition when coarray descriptors have a
+	     "token" component. This condition occurs when passing an alloc
+	      coarray or assumed-shape dummy to an explict-shape dummy.  */
+	{
+	  /* Token and offset. */
+	  VEC_safe_push (tree, gc, stringargs, null_pointer_node);
+	  VEC_safe_push (tree, gc, stringargs,
+			 build_int_cst (gfc_array_index_type, 0));
+	  gcc_assert (fsym->attr.optional || e != NULL); /* FIXME: "||" cond.  */
+	}
+      else if (fsym && fsym->attr.codimension
+	       && !fsym->attr.allocatable && fsym->as->type != AS_ASSUMED_SHAPE
+	       && gfc_option.coarray == GFC_FCOARRAY_LIB)
+	{
+	  tree caf_decl, caf_type;
+	  tree offset;
+
+          caf_decl = get_tree_for_caf_expr (e);
+	  caf_type = TREE_TYPE (caf_decl);
+
+	  gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
+		      && GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) != NULL_TREE);
+	  
+	  VEC_safe_push (tree, gc, stringargs,
+			 GFC_TYPE_ARRAY_CAF_TOKEN (caf_type));
+
+	  if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
+	    offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
+	  else
+	    offset = build_int_cst (gfc_array_index_type, 0);
+
+	  gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl))
+		      && POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
+
+	  tmp = fold_build2_loc (input_location, MINUS_EXPR,
+                                 gfc_array_index_type,
+                                 fold_convert (gfc_array_index_type,
+					       parmse.expr),
+                                 fold_convert (gfc_array_index_type,
+					       caf_decl));
+	  offset = fold_build2_loc (input_location, PLUS_EXPR,
+				    gfc_array_index_type, offset, tmp);
+
+	  VEC_safe_push (tree, gc, stringargs, offset);
+	}
+
       VEC_safe_push (tree, gc, arglist, parmse.expr);
     }
   gfc_finish_interface_mapping (&mapping, &se->pre, &se->post);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index c56aff8..48e054f 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -736,6 +736,7 @@  struct GTY((variable_size))	lang_type	 {
   tree base_decl[2];
   tree nonrestricted_type;
   tree caf_token;
+  tree caf_offset;
 };
 
 struct GTY((variable_size)) lang_decl {
@@ -781,6 +782,7 @@  struct GTY((variable_size)) lang_decl {
 #define GFC_TYPE_ARRAY_RANK(node) (TYPE_LANG_SPECIFIC(node)->rank)
 #define GFC_TYPE_ARRAY_CORANK(node) (TYPE_LANG_SPECIFIC(node)->corank)
 #define GFC_TYPE_ARRAY_CAF_TOKEN(node) (TYPE_LANG_SPECIFIC(node)->caf_token)
+#define GFC_TYPE_ARRAY_CAF_OFFSET(node) (TYPE_LANG_SPECIFIC(node)->caf_offset)
 #define GFC_TYPE_ARRAY_SIZE(node) (TYPE_LANG_SPECIFIC(node)->size)
 #define GFC_TYPE_ARRAY_OFFSET(node) (TYPE_LANG_SPECIFIC(node)->offset)
 #define GFC_TYPE_ARRAY_AKIND(node) (TYPE_LANG_SPECIFIC(node)->akind)
--- /dev/null	2011-07-19 07:59:35.374731880 +0200
+++ gcc/gcc/testsuite//gfortran.dg/coarray_lib_token_1.f90	2011-07-20 23:03:06.000000000 +0200
@@ -0,0 +1,88 @@ 
+! { dg-do compile }
+! { dg-options "-fcoarray=lib -fdump-tree-original" }
+!
+! Check whether TOKEN and OFFSET are correctly propagated
+! 
+
+program main
+  implicit none
+  type t
+    integer(4) :: a, b
+  end type t
+  integer :: caf[*]
+  type(t) :: caf_dt[*]
+
+  caf = 42
+  caf_dt = t (1,2)
+  call sub (caf, caf_dt%b)
+  print *,caf, caf_dt%b
+  if (caf /= -99 .or. caf_dt%b /= -101) call abort ()
+  call sub_opt ()
+  call sub_opt (caf)
+  if (caf /= 124) call abort ()
+contains
+
+  subroutine sub (x1, x2)
+    integer :: x1[*], x2[*]
+
+    call sub2 (x1, x2)
+  end subroutine sub
+
+  subroutine sub2 (y1, y2)
+    integer :: y1[*], y2[*]
+
+    print *, y1, y2
+    if (y1 /= 42 .or. y2 /= 2) call abort ()
+    y1 = -99
+    y2 = -101
+  end subroutine sub2
+
+  subroutine sub_opt (z)
+    integer, optional :: z[*]
+    if (present (z)) then
+      if (z /= -99) call abort ()
+      z = 124
+    end if
+  end subroutine sub_opt
+
+end program main
+
+! SCAN TREE DUMP AND CLEANUP
+!
+! PROTOTYPE 1:
+!
+! sub (integer(kind=4) * restrict x1, integer(kind=4) * restrict x2,
+!      void * restrict caf_token.4, integer(kind=8) caf_offset.5,
+!      void * restrict caf_token.6, integer(kind=8) caf_offset.7)
+!
+! { dg-final { scan-tree-dump-times "sub \\(integer.kind=4. . restrict x1, integer.kind=4. . restrict x2, void . restrict caf_token.\[0-9\]+, integer.kind=.. caf_offset.\[0-9\]+, void . restrict caf_token.\[0-9\]+, integer.kind=.. caf_offset.\[0-9\]+\\)" 1 "original"} }
+!
+! PROTOTYPE 2:
+!
+! sub2 (integer(kind=4) * restrict y1, integer(kind=4) * restrict y2,
+!       void * restrict caf_token.0, integer(kind=8) caf_offset.1,
+!       void * restrict caf_token.2, integer(kind=8) caf_offset.3)
+!
+! { dg-final { scan-tree-dump-times "sub2 \\(integer.kind=4. . restrict y1, integer.kind=4. . restrict y2, void . restrict caf_token.\[0-9\]+, integer.kind=.. caf_offset.\[0-9\]+, void . restrict caf_token.\[0-9\]+, integer.kind=.. caf_offset.\[0-9\]+\\)" 1 "original"} }
+!
+! CALL 1
+!
+!  sub ((integer(kind=4) *) caf, &caf_dt->b, caf_token.9, 0, caf_token.10, 4);
+!
+! { dg-final { scan-tree-dump-times "sub \\(\[^,\]*caf, &caf_dt->b, caf_token.\[0-9\]+, 0, caf_token.\[0-9\]+, 4\\)" 1 "original"} }
+!
+!  sub2 ((integer(kind=4) *) x1, (integer(kind=4) *) x2,
+!        caf_token.4, NON_LVALUE_EXPR <caf_offset.5>,
+!        caf_token.6, NON_LVALUE_EXPR <caf_offset.7>);
+!
+! { dg-final { scan-tree-dump-times "sub2 \\(\[^,\]*x1, \[^,\]*x2, caf_token.\[0-9]+, \[^,\]*caf_offset\[^,\]*, caf_token.\[0-9\]+, \[^,\]*caf_offset\[^,\]*\\)" 1 "original"} }
+!
+! CALL 3
+!
+! { dg-final { scan-tree-dump-times "sub_opt \\(0B, 0B, 0\\)" 1 "original"} }
+!
+! CALL 4
+!
+! { dg-final { scan-tree-dump-times "sub_opt \\(.integer.kind=4. .. caf, caf_token.\[0-9\]+, 0\\)" 1 "original"} }
+!
+! { dg-final { cleanup-tree-dump "original" } }