Re: [Fortran, Patch] Some prep patches for coarray communication

Re: [Fortran, Patch] Some prep patches for coarray communication

[Paul Richard Thomas]

Dear Tobias,

This one is fine for trunk.

Thanks for the patch.

Paul

[Fortran, Patch] Some prep patches for coarray communication

[Tobias Burnus]

[-- Attachment #1: Type: text/plain, Size: 1022 bytes --]

This patch is a teaser: It adds some preparation for coarray 
communication to the trunk, but it doesn't yet added the library calls. 
(In particular, note the "0 &&" in the conditions, which add the 
intrinsics.)

The idea is that coindexed variables are wrapped in the intrinsic 
function caf_get(expr) and assignments to coindexed variables are 
wrapped into the subroutine caf_send(LHS, RHS). Both intrinsic 
procedures are only internally reachable. The intrinsic procedures are 
then converted into library calls in trans-intrinsic.c. (See fortran-caf 
branch.)

I am not yet submitting the the trans-intrinsic.c part as I still want 
to restructure the current version – and I am also unsure how exactly I 
should handle allocatable components of coarrays. But as this part 
should be ready, I thought that I already submit it, reducing the 
differences between the branch and the trunk. However, I can also hold 
off this patch until it is actually used.

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

Tobias

[-- Attachment #2: prep-caf.diff --]
[-- Type: text/x-patch, Size: 7457 bytes --]

2014-05-04  Tobias Burnus  <burnus@net-b.de>

	* gfortran.h (gfc_isym_id): Add GFC_ISYM_CAF_GET
	and GFC_ISYM_CAF_SEND.
	* intrinsic.c (add_functions): Add only internally
	accessible caf_get and caf_send functions.
	* resolve.c (add_caf_get_intrinsic,
	remove_caf_get_intrinsic): New functions.
	(resolve_variable): Resolve expression rank and
	prepare for add_caf_get_intrinsic call.
	(gfc_resolve_expr): For variables, remove rank
	resolution.
	(resolve_ordinary_assign): Prepare call to
	GFC_ISYM_CAF_SEND.
	(resolve_code): Avoid call to GFC_ISYM_CAF_GET for
	the LHS of an assignment.

diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index 852ae92..4c2eaa5 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -2758,3 +2758,3 @@ add_functions (void)
   /* Obtain the stride for a given dimensions; to be used only internally.
-     "make_from_module" makes inaccessible for external users.  */
+     "make_from_module" makes it inaccessible for external users.  */
   add_sym_2 (GFC_PREFIX ("stride"), GFC_ISYM_STRIDE, CLASS_INQUIRY, ACTUAL_NO,
@@ -2996,2 +2996,9 @@ add_functions (void)
   make_generic ("loc", GFC_ISYM_LOC, GFC_STD_GNU);
+
+  /* The following function is internally used for coarray libray functions.
+     "make_from_module" makes it inaccessible for external users.  */
+  add_sym_1 (GFC_PREFIX ("caf_get"), GFC_ISYM_CAF_GET, CLASS_IMPURE, ACTUAL_NO,
+	     BT_REAL, dr, GFC_STD_GNU, NULL, NULL, NULL,
+	     x, BT_REAL, dr, REQUIRED);
+  make_from_module();
 }
@@ -3237,2 +3244,11 @@ add_subroutines (void)
 
+  /* The following subroutine is internally used for coarray libray functions.
+     "make_from_module" makes it inaccessible for external users.  */
+  add_sym_2s (GFC_PREFIX ("caf_send"), GFC_ISYM_CAF_SEND, CLASS_IMPURE,
+	      BT_UNKNOWN, 0, GFC_STD_GNU, NULL, NULL, NULL,
+	      "x", BT_REAL, dr, REQUIRED, INTENT_OUT,
+	      "y", BT_REAL, dr, REQUIRED, INTENT_IN);
+  make_from_module();
+
+
   /* More G77 compatibility garbage.  */
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 63be8af..d654d2b 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -318,6 +318,8 @@ enum gfc_isym_id
   GFC_ISYM_BLE,
   GFC_ISYM_BLT,
   GFC_ISYM_BTEST,
+  GFC_ISYM_CAF_GET,
+  GFC_ISYM_CAF_SEND,
   GFC_ISYM_CEILING,
   GFC_ISYM_CHAR,
   GFC_ISYM_CHDIR,
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 15c9463..241b85e 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -4726,14 +4726,58 @@ expression_rank (gfc_expr *e)
   e->rank = rank;
 
 done:
   expression_shape (e);
 }
 
 
+static void
+add_caf_get_intrinsic (gfc_expr *e)
+{
+  gfc_expr *wrapper, *tmp_expr;
+  gfc_ref *ref;
+  int n;
+
+  for (ref = e->ref; ref; ref = ref->next)
+    if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
+      break;
+  if (ref == NULL)
+    return;
+
+  for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
+    if (ref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
+      return;
+
+  tmp_expr = XCNEW (gfc_expr);
+  *tmp_expr = *e;
+  wrapper = gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_CAF_GET,
+				      "caf_get", tmp_expr->where, 1, tmp_expr);
+  wrapper->ts = e->ts;
+  wrapper->rank = e->rank;
+  if (e->rank)
+    wrapper->shape = gfc_copy_shape (e->shape, e->rank);
+  *e = *wrapper;
+  free (wrapper);
+}
+
+
+static void
+remove_caf_get_intrinsic (gfc_expr *e)
+{
+  gcc_assert (e->expr_type == EXPR_FUNCTION && e->value.function.isym
+	      && e->value.function.isym->id == GFC_ISYM_CAF_GET);
+  gfc_expr *e2 = e->value.function.actual->expr;
+  e->value.function.actual->expr =NULL;
+  gfc_free_actual_arglist (e->value.function.actual);
+  gfc_free_shape (&e->shape, e->rank);
+  *e = *e2;
+  free (e2);
+}
+
+
 /* Resolve a variable expression.  */
 
 static bool
 resolve_variable (gfc_expr *e)
 {
   gfc_symbol *sym;
   bool t;
@@ -5005,14 +5049,20 @@ resolve_procedure:
 			 "subcomponent at %L", &e->where);
 		t = false;
 		break;
 	      }
 	}
     }
 
+  if (t)
+    expression_rank (e);
+
+  if (0 && t && gfc_option.coarray == GFC_FCOARRAY_LIB && gfc_is_coindexed (e))
+    add_caf_get_intrinsic (e);
+
   return t;
 }
 
 
 /* Checks to see that the correct symbol has been host associated.
    The only situation where this arises is that in which a twice
    contained function is parsed after the host association is made.
@@ -6088,19 +6138,15 @@ gfc_resolve_expr (gfc_expr *e)
 
     case EXPR_FUNCTION:
     case EXPR_VARIABLE:
 
       if (check_host_association (e))
 	t = resolve_function (e);
       else
-	{
-	  t = resolve_variable (e);
-	  if (t)
-	    expression_rank (e);
-	}
+	t = resolve_variable (e);
 
       if (e->ts.type == BT_CHARACTER && e->ts.u.cl == NULL && e->ref
 	  && e->ref->type != REF_SUBSTRING)
 	gfc_resolve_substring_charlen (e);
 
       break;
 
@@ -9210,23 +9256,44 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
     {
       gfc_error ("Nonallocatable variable must not be polymorphic in intrinsic "
 		 "assignment at %L - check that there is a matching specific "
 		 "subroutine for '=' operator", &lhs->where);
       return false;
     }
 
+  bool lhs_coindexed = gfc_is_coindexed (lhs);
+
   /* F2008, Section 7.2.1.2.  */
-  if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs))
+  if (lhs_coindexed && gfc_has_ultimate_allocatable (lhs))
     {
       gfc_error ("Coindexed variable must not have an allocatable ultimate "
 		 "component in assignment at %L", &lhs->where);
       return false;
     }
 
   gfc_check_assign (lhs, rhs, 1);
+
+  if (0 && lhs_coindexed && gfc_option.coarray == GFC_FCOARRAY_LIB)
+    {
+      code->op = EXEC_CALL;
+      gfc_get_sym_tree (GFC_PREFIX ("caf_send"), ns, &code->symtree, true);
+      code->resolved_sym = code->symtree->n.sym;
+      code->resolved_sym->attr.flavor = FL_PROCEDURE;
+      code->resolved_sym->attr.intrinsic = 1;
+      code->resolved_sym->attr.subroutine = 1;
+      code->resolved_isym = gfc_intrinsic_subroutine_by_id (GFC_ISYM_CAF_SEND);
+      gfc_commit_symbol (code->resolved_sym);
+      code->ext.actual = gfc_get_actual_arglist ();
+      code->ext.actual->expr = lhs;
+      code->ext.actual->next = gfc_get_actual_arglist ();
+      code->ext.actual->next->expr = rhs;
+      code->expr1 = NULL;
+      code->expr2 = NULL;
+    }
+
   return false;
 }
 
 
 /* Add a component reference onto an expression.  */
 
 static void
@@ -9841,28 +9908,33 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
 	case EXEC_END_PROCEDURE:
 	  break;
 
 	case EXEC_ASSIGN:
 	  if (!t)
 	    break;
 
+	  if (code->expr1->expr_type == EXPR_FUNCTION
+	      && code->expr1->value.function.isym
+	      && code->expr1->value.function.isym->id == GFC_ISYM_CAF_GET)
+	    remove_caf_get_intrinsic (code->expr1);
+
 	  if (!gfc_check_vardef_context (code->expr1, false, false, false, 
 					 _("assignment")))
 	    break;
 
 	  if (resolve_ordinary_assign (code, ns))
 	    {
 	      if (code->op == EXEC_COMPCALL)
 		goto compcall;
 	      else
 		goto call;
 	    }
 
 	  /* F03 7.4.1.3 for non-allocatable, non-pointer components.  */
-	  if (code->expr1->ts.type == BT_DERIVED
+	  if (code->op != EXEC_CALL && code->expr1->ts.type == BT_DERIVED
 	      && code->expr1->ts.u.derived->attr.defined_assign_comp)
 	    generate_component_assignments (&code, ns);
 
 	  break;
 
 	case EXEC_LABEL_ASSIGN:
 	  if (code->label1->defined == ST_LABEL_UNKNOWN)