Patchwork [Fortran] Coarray assumed-shape token and offset handling

login
register
mail settings
Submitter Tobias Burnus
Date Aug. 22, 2011, 9:22 p.m.
Message ID <4E52C880.8020208@net-b.de>
Download mbox | patch
Permalink /patch/110993/
State New
Headers show

Comments

Tobias Burnus - Aug. 22, 2011, 9:22 p.m.
Dear all,

this patch added token/offset support for assumed-shape coarray dummies 
(with .-fcoarray=lib).

Build and regtested.
OK for the trunk?

  * * *


BACKGROUND

For coarrays with -fcoarray=lib, for remote access, one needs to know 
two things: token and offset.

a) A token (of type "void *") identifies the coarray in the library; its 
value is set when the coarray is registered. (For instance, it could 
store the base address of the coarray on all images).

b) The offset between the base address of the coarray and the value one 
wants to assign.

Recall, if
    type(t) :: a(:)[*]
is a coarray (is this case: an assumed-shape dummy argument), then all 
of the following are also coarrays:  a,  a(1:4), a(1), a(1)%direct_comp, 
a(2)%direct_comp(2:7), a(4)%direct_comp(3)



CURRENT IMPLEMENTATION for descriptorless and allocatable coarrays

For descriptorless coarrays (scalar or array), those values are stored 
as language-specific type nodes (TYPE_LANG_SPECIFIC), namely: 
GFC_TYPE_ARRAY_CAF_TOKEN and .GFC_TYPE_ARRAY_CAF_OFFSET.

For descriptorless coarray dummies (scalar or array), the token and the 
offset are passed as hidden dummy arguments - similar to string lengths.


For allocatable coarrays (array and scalar), the cobound is transferred 
via additional dimension triplets and the the token is stored in the 
descriptor as tailing component. The token is accessible via 
gfc_conv_descriptor_token.


THIS PATCH: Assumed-shape coarrays

Assumed shape coarrays are declared as, e.g.,
   integer :: A(:,:)[*]
thus, contrary to deferred-shape/allocatable coarrays, the codimension 
does not need to be passed (and the corank can be differ between actual 
and dummy argument). However, both token and offset are important since 
this information is not passed.

Handled by passing the token/offset as hidden argument and saving it in 
a lang_decl node.

Tobias
Mikael Morin - Aug. 25, 2011, 4:12 p.m.
On Monday 22 August 2011 23:22:08 Tobias Burnus wrote:
> Dear all,
> 
> this patch added token/offset support for assumed-shape coarray dummies
> (with .-fcoarray=lib).
> 
> Build and regtested.
> OK for the trunk?
> 
OK, thanks.

Mikael

Patch

2011-08-23  Tobias Burnus  <burnus@net-b.de>

	* trans-array.c (gfc_conv_descriptor_token): Add assert.
	* trans-decl.c (gfc_build_qualified_array,
	create_function_arglist): Handle assumed-shape arrays.
	* trans-expr.c (gfc_conv_procedure_call): Ditto.
	* trans-types.c (gfc_get_array_descriptor_base): Ditto, don't
	add "caf_token" to assumed-shape descriptors, new akind argument.
	(gfc_get_array_type_bounds): Pass akind.
	* trans.h (lang_decl): New elements caf_offset and token.
	(GFC_DECL_TOKEN, GFC_DECL_CAF_OFFSET): New macros.

2011-08-23  Tobias Burnus  <burnus@net-b.de>

	* gfortran.dg/coarray_lib_token_4.f90: New.

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 3a75658..c5e1940 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -277,6 +277,7 @@  gfc_conv_descriptor_token (tree desc)
 
   type = TREE_TYPE (desc);
   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+  gcc_assert (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE);
   gcc_assert (gfc_option.coarray == GFC_FCOARRAY_LIB);
   field = gfc_advance_chain (TYPE_FIELDS (type), CAF_TOKEN_FIELD);
   gcc_assert (field != NULL_TREE && TREE_TYPE (field) == prvoid_type_node);
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index cdbb375..1059a42 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -755,6 +755,7 @@  gfc_build_qualified_array (tree decl, gfc_symbol * sym)
 	 && !sym->attr.contained;
 
   if (sym->attr.codimension && gfc_option.coarray == GFC_FCOARRAY_LIB
+      && sym->as->type != AS_ASSUMED_SHAPE
       && GFC_TYPE_ARRAY_CAF_TOKEN (type) == NULL_TREE)
     {
       tree token;
@@ -2104,12 +2105,11 @@  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.  */
+      /* Coarrays which are descriptorless or assumed-shape 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)
+	  && !f->sym->attr.allocatable)
 	{
 	  tree caf_type;
 	  tree token;
@@ -2119,12 +2119,24 @@  create_function_arglist (gfc_symbol * sym)
 		      && !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;
+	  if (f->sym->as->type == AS_ASSUMED_SHAPE)
+	    {
+	      gcc_assert (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL
+			  || GFC_DECL_TOKEN (f->sym->backend_decl) == NULL_TREE);
+	      if (DECL_LANG_SPECIFIC (f->sym->backend_decl) == NULL)
+		gfc_allocate_lang_decl (f->sym->backend_decl);
+	      GFC_DECL_TOKEN (f->sym->backend_decl) = token;
+	    }
+          else
+	    {
+	      gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) == NULL_TREE);
+	      GFC_TYPE_ARRAY_CAF_TOKEN (caf_type) = token;
+	    }
+	    
 	  DECL_CONTEXT (token) = fndecl;
 	  DECL_ARTIFICIAL (token) = 1;
 	  DECL_ARG_TYPE (token) = TREE_VALUE (typelist);
@@ -2132,12 +2144,21 @@  create_function_arglist (gfc_symbol * sym)
 	  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;
+	  if (f->sym->as->type == AS_ASSUMED_SHAPE)
+	    {
+	      gcc_assert (GFC_DECL_CAF_OFFSET (f->sym->backend_decl)
+					       == NULL_TREE);
+	      GFC_DECL_CAF_OFFSET (f->sym->backend_decl) = offset;
+	    }
+	  else
+	    {
+	      gcc_assert (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) == NULL_TREE);
+	      GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) = offset;
+	    }
 	  DECL_CONTEXT (offset) = fndecl;
 	  DECL_ARTIFICIAL (offset) = 1;
 	  DECL_ARG_TYPE (offset) = TREE_VALUE (typelist);
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 39a83ce..db8a89f 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -3390,11 +3390,11 @@  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.  */
+      /* For descriptorless coarrays and assumed-shape coarray dummies, 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
+	  && !fsym->attr.allocatable
 	  && e == NULL)
 	{
 	  /* Token and offset. */
@@ -3404,7 +3404,7 @@  gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  gcc_assert (fsym->attr.optional);
 	}
       else if (fsym && fsym->attr.codimension
-	       && !fsym->attr.allocatable && fsym->as->type != AS_ASSUMED_SHAPE
+	       && !fsym->attr.allocatable
 	       && gfc_option.coarray == GFC_FCOARRAY_LIB)
 	{
 	  tree caf_decl, caf_type;
@@ -3413,8 +3413,12 @@  gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  caf_decl = get_tree_for_caf_expr (e);
 	  caf_type = TREE_TYPE (caf_decl);
 
-	  if (GFC_DESCRIPTOR_TYPE_P (caf_type))
+	  if (GFC_DESCRIPTOR_TYPE_P (caf_type)
+	      && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
 	    tmp = gfc_conv_descriptor_token (caf_decl);
+	  else if (DECL_LANG_SPECIFIC (caf_decl)
+		   && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
+	    tmp = GFC_DECL_TOKEN (caf_decl);
 	  else
 	    {
 	      gcc_assert (GFC_ARRAY_TYPE_P (caf_type)
@@ -3424,8 +3428,12 @@  gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	  
 	  VEC_safe_push (tree, gc, stringargs, tmp);
 
-	  if (GFC_DESCRIPTOR_TYPE_P (caf_type))
+	  if (GFC_DESCRIPTOR_TYPE_P (caf_type)
+	      && GFC_TYPE_ARRAY_AKIND (caf_type) == GFC_ARRAY_ALLOCATABLE)
 	    offset = build_int_cst (gfc_array_index_type, 0);
+	  else if (DECL_LANG_SPECIFIC (caf_decl)
+		   && GFC_DECL_CAF_OFFSET (caf_decl) != NULL_TREE)
+	    offset = GFC_DECL_CAF_OFFSET (caf_decl);
 	  else if (GFC_TYPE_ARRAY_CAF_OFFSET (caf_type) != NULL_TREE)
 	    offset = GFC_TYPE_ARRAY_CAF_OFFSET (caf_type);
 	  else
@@ -3439,7 +3447,15 @@  gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 	      tmp = caf_decl;
 	    }
 
-	  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse.expr)))
+          if (fsym->as->type == AS_ASSUMED_SHAPE)
+	    {
+	      gcc_assert (POINTER_TYPE_P (TREE_TYPE (parmse.expr)));
+	      gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE
+						   (TREE_TYPE (parmse.expr))));
+	      tmp2 = build_fold_indirect_ref_loc (input_location, parmse.expr);
+	      tmp2 = gfc_conv_descriptor_data_get (tmp2);
+	    }
+	  else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse.expr)))
 	    tmp2 = gfc_conv_descriptor_data_get (parmse.expr);
 	  else
 	    {
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index bec2a11..458e947 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1614,10 +1614,12 @@  gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
   return type;
 }
 
+
 /* Return or create the base type for an array descriptor.  */
 
 static tree
-gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
+gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted,
+			       enum gfc_array_kind akind)
 {
   tree fat_type, decl, arraytype, *chain = NULL;
   char name[16 + 2*GFC_RANK_DIGITS + 1 + 1];
@@ -1671,7 +1673,8 @@  gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
 				    arraytype, &chain);
   TREE_NO_WARNING (decl) = 1;
 
-  if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen)
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen
+      && akind == GFC_ARRAY_ALLOCATABLE)
     {
       decl = gfc_add_field_to_struct_1 (fat_type,
 					get_identifier ("token"),
@@ -1683,7 +1686,8 @@  gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
   gfc_finish_type (fat_type);
   TYPE_DECL_SUPPRESS_DEBUG (TYPE_STUB_DECL (fat_type)) = 1;
 
-  if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen)
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB && codimen
+      && akind == GFC_ARRAY_ALLOCATABLE)
     gfc_array_descriptor_base_caf[idx] = fat_type;
   else
     gfc_array_descriptor_base[idx] = fat_type;
@@ -1691,6 +1695,7 @@  gfc_get_array_descriptor_base (int dimen, int codimen, bool restricted)
   return fat_type;
 }
 
+
 /* Build an array (descriptor) type with given bounds.  */
 
 tree
@@ -1703,11 +1708,11 @@  gfc_get_array_type_bounds (tree etype, int dimen, int codimen, tree * lbound,
   const char *type_name;
   int n;
 
-  base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted);
+  base_type = gfc_get_array_descriptor_base (dimen, codimen, restricted, akind);
   fat_type = build_distinct_type_copy (base_type);
   /* Make sure that nontarget and target array type have the same canonical
      type (and same stub decl for debug info).  */
-  base_type = gfc_get_array_descriptor_base (dimen, codimen, false);
+  base_type = gfc_get_array_descriptor_base (dimen, codimen, false, akind);
   TYPE_CANONICAL (fat_type) = base_type;
   TYPE_STUB_DECL (fat_type) = TYPE_STUB_DECL (base_type);
 
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index bb94780..0c249a6 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -750,12 +750,16 @@  struct GTY((variable_size)) lang_decl {
   tree stringlen;
   tree addr;
   tree span;
+  /* For assumed-shape coarrays.  */
+  tree token, caf_offset;
 };
 
 
 #define GFC_DECL_ASSIGN_ADDR(node) DECL_LANG_SPECIFIC(node)->addr
 #define GFC_DECL_STRING_LEN(node) DECL_LANG_SPECIFIC(node)->stringlen
 #define GFC_DECL_SPAN(node) DECL_LANG_SPECIFIC(node)->span
+#define GFC_DECL_TOKEN(node) DECL_LANG_SPECIFIC(node)->token
+#define GFC_DECL_CAF_OFFSET(node) DECL_LANG_SPECIFIC(node)->caf_offset
 #define GFC_DECL_SAVED_DESCRIPTOR(node) \
   (DECL_LANG_SPECIFIC(node)->saved_descriptor)
 #define GFC_DECL_PACKED_ARRAY(node) DECL_LANG_FLAG_0(node)
--- /dev/null	2011-08-22 07:33:18.402869820 +0200
+++ gcc/gcc/testsuite/gfortran.dg/coarray_lib_token_4.f90	2011-08-22 23:12:24.000000000 +0200
@@ -0,0 +1,53 @@ 
+! { dg-do compile }
+! { dg-options "-fcoarray=lib -fdump-tree-original" }
+!
+! Check argument passing with assumed-shape coarray dummies
+!
+program test_caf
+  implicit none
+  integer, allocatable :: A(:)[:]
+  integer, save :: B(3)[*]
+  integer :: i
+
+  allocate (A(3)[*])
+  A = [1, 2, 3 ] 
+  B = [9, 7, 4 ]
+  call foo (A, A, test=1)
+  call foo (A(2:3), B, test=2)
+  call foo (B, A, test=3)
+contains
+  subroutine foo(x, y, test)
+    integer :: x(:)[*]
+    integer, contiguous :: y(:)[*]
+    integer :: test
+    call bar (x)
+    call expl (y)
+  end subroutine foo
+
+  subroutine bar(y)
+    integer :: y(:)[*]
+  end subroutine bar
+
+  subroutine expl(z)
+    integer :: z(*)[*]
+  end subroutine expl
+end program test_caf
+
+! { dg-final { scan-tree-dump-times "expl \\(integer\\(kind=4\\).0:. . restrict z, void . restrict caf_token.\[0-9\]+, integer\\(kind=.\\) caf_offset.\[0-9\]+\\)" 1 "original" } }
+!
+! { dg-final { scan-tree-dump-times "bar \\(struct array2_integer\\(kind=4\\) & restrict y, void . restrict caf_token.\[0-9\]+, integer\\(kind=.\\) caf_offset.\[0-9\]+\\)" 1 "original" } }
+!
+! { dg-final { scan-tree-dump-times "foo \\(struct array2_integer\\(kind=4\\) & restrict x, struct array2_integer\\(kind=4\\) & restrict y, integer\\(kind=4\\) & restrict test, 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" } }
+!
+! { dg-final { scan-tree-dump-times "bar \\(&parm.\[0-9\]+, caf_token.\[0-9\]+, \\(\\(integer\\(kind=.\\)\\) parm.\[0-9\]+.data - \\(integer\\(kind=.\\)\\) x.\[0-9\]+\\) \\+ caf_offset.\[0-9\]+\\);" 1 "original" } }
+! { d_g-final { scan-tree-dump-times "bar \\(&parm.\[0-9\]+, caf_token.\[0-9\]+, \\(\\(integer\\(kind=.\\) parm.\[0-9\]+.data - \\(integer\\(kind=.\\)\\) x.\[0-9\]+\\) \\+ caf_offset.\[0-9\]+\\);" 1 "original" } }
+!
+! { dg-final { scan-tree-dump-times "expl \\(\\(integer\\(kind=4\\).0:. .\\) parm.\[0-9\]+.data, caf_token.\[0-9\]+, \\(\\(integer\\(kind=.\\)\\) parm.\[0-9\]+.data - \\(\\(integer\\(kind=.\\)\\) y.\[0-9\]+\\) \\+ caf_offset.\[0-9\]+\\);" 0 "original" } }
+!
+! { dg-final { scan-tree-dump-times "foo \\(&a, &a, &C.\[0-9\]+, a.token, 0, a.token, 0\\);" 1 "original" } }
+!
+! { dg-final { scan-tree-dump-times "foo \\(&parm.\[0-9\]+, &parm.\[0-9\]+, &C.\[0-9\]+, a.token, \\(integer\\(kind=.\\)\\) parm.\[0-9\]+.data - \\(integer\\(kind=.\\)\\) a.data, caf_token.\[0-9\]+, \\(integer\\(kind=.\\)\\) parm.\[0-9\]+.data - \\(integer\\(kind=.\\)\\) b\\);" 1 "original" } }
+!
+! { dg-final { scan-tree-dump-times "foo \\(&parm.\[0-9\]+, &a, &C.\[0-9\]+, caf_token.\[0-9\]+, \\(integer\\(kind=.\\)\\) parm.\[0-9\]+.data - \\(integer\\(kind=.\\)\\) b, a.token, 0\\);" 1 "original" } }
+!
+! { dg-final { cleanup-tree-dump "original" } }