Patchwork [Fortran-CAF,committed] Implement the library call for caf_send

login
register
mail settings
Submitter Tobias Burnus
Date March 28, 2014, 12:39 a.m.
Message ID <5334C4DE.7000906@net-b.de>
Download mbox | patch
Permalink /patch/334516/
State New
Headers show

Comments

Tobias Burnus - March 28, 2014, 12:39 a.m.
This patch implements the call to the library for code of the form:
    caf[j] = (rhs - expr)

Caveats: It currently only handles scalars and for characters only 
len-one ones. While it copies also derived types, it does not handle 
allocatable components.

With a suitable communication library, this patch finally permits real 
multi-image communication. Hooray!


The next steps are (in no specific order and without committal to do it 
myself):
- Adding test cases for this code (dumps, -fcaf_single run-time checks)
- supporting array sections and array vector sections
- supporting len > 1 character strings
- allocatable/pointer components of coarrays
- supporting coindexed coarray on the RHS.

Committed to the Fortran-CAF branch as Rev.

Tobias

Patch

Index: gcc/fortran/ChangeLog.fortran-caf
===================================================================
--- gcc/fortran/ChangeLog.fortran-caf	(Revision 208886)
+++ gcc/fortran/ChangeLog.fortran-caf	(Arbeitskopie)
@@ -1,3 +1,10 @@ 
+2014-03-28  Tobias Burnus  <burnus@net-b.de>
+
+	* trans-intrinsic.c (caf_get_image_index, conv_caf_send): New.
+	(gfc_conv_intrinsic_subroutine): Call it.
+	* resolve.c (resolve_ordinary_assign): Enable coindex LHS
+	support for -fcoarray=lib.
+
 2014-03-15  Tobias Burnus  <burnus@net-b.de>
 
 	* gfortran.h (gfc_isym_id): Add GFC_ISYM_CAF_SEND.
@@ -6,6 +13,8 @@ 
 	* resolve.c (resolve_ordinary_assign): Prepare the
 	replacement of the assignment for coindexed LHS by
 	a call to caf_send.
+	(resolve_code): Ignore component_assignments for those
+	assignments which have been replaced.
 
 2014-03-14  Tobias Burnus  <burnus@net-b.de>
 
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(Revision 208886)
+++ gcc/fortran/resolve.c	(Arbeitskopie)
@@ -9229,7 +9229,7 @@  resolve_ordinary_assign (gfc_code *code, gfc_names
 
   gfc_check_assign (lhs, rhs, 1);
 
-  if (false && lhs_coindexed && gfc_option.coarray == GFC_FCOARRAY_LIB)
+  if (lhs_coindexed && gfc_option.coarray == GFC_FCOARRAY_LIB)
     {
       code->op = EXEC_CALL;
       gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree, true);
Index: gcc/fortran/trans-intrinsic.c
===================================================================
--- gcc/fortran/trans-intrinsic.c	(Revision 208886)
+++ gcc/fortran/trans-intrinsic.c	(Arbeitskopie)
@@ -7788,6 +7788,182 @@  conv_intrinsic_move_alloc (gfc_code *code)
 }
 
 
+/* Convert the coindex of a coarray into an image index; the result is
+   image_num =  (idx(1)-lcobound(1)+1) + (idx(2)-lcobound(2)+1)*extent(1)
+              + (idx(3)-lcobound(3)+1)*extent(2) + ...  */
+
+static tree
+caf_get_image_index (stmtblock_t *block, gfc_expr *e, tree desc)
+{
+  gfc_ref *ref;
+  tree lbound, ubound, extent, tmp, img_idx;
+  gfc_se se;
+  int i;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
+      break;
+  gcc_assert (ref != NULL);
+
+  img_idx = integer_zero_node;
+  extent = integer_one_node;
+  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)))
+    for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
+      {
+	gfc_init_se (&se, NULL);
+	gfc_conv_expr_type (&se, ref->u.ar.start[i], integer_type_node);
+	gfc_add_block_to_block (block, &se.pre);
+	lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]);
+	tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			       integer_type_node, se.expr,
+			       fold_convert(integer_type_node, lbound));
+	tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
+			       tmp, integer_one_node);
+	tmp = fold_build2_loc (input_location, MULT_EXPR, integer_type_node,
+			       extent, tmp);
+	img_idx = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
+				   img_idx, tmp);
+	if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
+	  {
+	    ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]);
+	    extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
+	    extent = fold_convert (integer_type_node, extent);
+	  }
+      }
+  else
+    for (i = ref->u.ar.dimen; i < ref->u.ar.dimen + ref->u.ar.codimen; i++)
+      {
+	gfc_init_se (&se, NULL);
+	gfc_conv_expr_type (&se, ref->u.ar.start[i], integer_type_node);
+	gfc_add_block_to_block (block, &se.pre);
+	lbound = GFC_TYPE_ARRAY_LBOUND (TREE_TYPE (desc), i);
+	lbound = fold_convert (integer_type_node, lbound);
+	tmp = fold_build2_loc (input_location, MINUS_EXPR,
+			       integer_type_node, se.expr, lbound);
+	tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
+			       tmp, integer_one_node);
+	tmp = fold_build2_loc (input_location, MULT_EXPR, integer_type_node,
+			       extent, tmp);
+	img_idx = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
+				   img_idx, tmp);
+	if (i < ref->u.ar.dimen + ref->u.ar.codimen - 1)
+	  {
+	    ubound = GFC_TYPE_ARRAY_UBOUND (TREE_TYPE (desc), i);
+	    ubound = fold_convert (integer_type_node, ubound);
+	    extent = fold_build2_loc (input_location, MINUS_EXPR,
+				      integer_type_node, ubound, lbound);
+	    extent = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
+				      extent, integer_one_node);
+	  }
+      }
+  return img_idx;
+}
+
+
+/* Send data to a remove coarray.  */
+
+static tree
+conv_caf_send (gfc_code *code) {
+  gfc_expr *lhs_expr, *rhs_expr, *async_expr;
+  gfc_se lhs_se, rhs_se, async_se;
+  stmtblock_t block;
+  tree caf_decl, token, offset, image_index, tmp;
+ 
+  gcc_assert (gfc_option.coarray == GFC_FCOARRAY_LIB);
+
+  lhs_expr = code->ext.actual->expr; 
+  rhs_expr = code->ext.actual->next->expr; 
+  async_expr = code->ext.actual->next->next->expr; 
+  gfc_init_block (&block);
+
+  /* LHS: The coarray.  */
+
+  if (lhs_expr->rank)
+    gfc_fatal_error ("Remote coarray access at %L for array sections not yet "
+		     " implemented", &lhs_expr->where);
+
+  gfc_init_se (&lhs_se, NULL);
+  gfc_conv_expr_reference (&lhs_se, lhs_expr);
+
+  caf_decl = gfc_get_tree_for_caf_expr (lhs_expr);
+  if (TREE_CODE (TREE_TYPE (caf_decl)) == REFERENCE_TYPE)
+    caf_decl = build_fold_indirect_ref_loc (input_location, caf_decl);
+  image_index = caf_get_image_index (&block, lhs_expr, caf_decl);
+
+  /* Coarray token.  */
+  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
+      && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == GFC_ARRAY_ALLOCATABLE)
+    token = gfc_conv_descriptor_token (caf_decl);
+  else if (DECL_LANG_SPECIFIC (caf_decl)
+	   && GFC_DECL_TOKEN (caf_decl) != NULL_TREE)
+    token = GFC_DECL_TOKEN (caf_decl);
+  else
+    {
+      gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (caf_decl))
+		  && GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl)) != NULL_TREE);
+      token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (caf_decl));
+    }
+
+  /* Offset between the coarray base address and the address wanted.  */
+  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl))
+      && GFC_TYPE_ARRAY_AKIND (TREE_TYPE (caf_decl)) == 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 (TREE_TYPE (caf_decl)) != NULL_TREE)
+    offset = GFC_TYPE_ARRAY_CAF_OFFSET (TREE_TYPE (caf_decl));
+  else
+    offset = build_int_cst (gfc_array_index_type, 0);
+
+  if (POINTER_TYPE_P (TREE_TYPE (lhs_se.expr))
+      && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (lhs_se.expr))))
+    {
+      tmp = build_fold_indirect_ref_loc (input_location, lhs_se.expr);
+      tmp = gfc_conv_descriptor_data_get (tmp);
+    }
+  else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (lhs_se.expr)))
+    tmp = gfc_conv_descriptor_data_get (lhs_se.expr);
+  else
+    {
+      gcc_assert (POINTER_TYPE_P (TREE_TYPE (lhs_se.expr)));
+      tmp = lhs_se.expr;
+    }
+
+  offset = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
+			    offset, tmp);
+
+  if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (caf_decl)))
+    tmp = gfc_conv_descriptor_data_get (caf_decl);
+  else
+   {
+     gcc_assert (POINTER_TYPE_P (TREE_TYPE (caf_decl)));
+     tmp = caf_decl;
+   }
+
+  offset = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
+                            offset, tmp);
+
+  /* RHS - a noncoarray.  */
+
+  gfc_init_se (&rhs_se, NULL);
+  rhs_se.want_pointer = 1;
+  gfc_conv_expr_reference (&rhs_se, rhs_expr);
+  gfc_add_block_to_block (&block, &rhs_se.pre);
+
+  gfc_init_se (&async_se, NULL);
+  gfc_conv_expr (&async_se, async_expr);
+
+  tree size = size_in_bytes (TREE_TYPE (TREE_TYPE (rhs_se.expr)));
+  tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_send, 6,
+			     token, offset, image_index, rhs_se.expr, size,
+			     fold_convert (boolean_type_node, async_se.expr));
+  gfc_add_expr_to_block (&block, tmp);
+  gfc_add_block_to_block (&block, &rhs_se.post);
+  return gfc_finish_block (&block);
+}
+
+
 tree
 gfc_conv_intrinsic_subroutine (gfc_code *code)
 {
@@ -7814,6 +7990,9 @@  gfc_conv_intrinsic_subroutine (gfc_code *code)
       res = conv_isocbinding_subroutine (code);
       break;
 
+    case GFC_ISYM_CAF_SEND:
+      res = conv_caf_send (code);
+      break;
 
     default:
       res = NULL_TREE;