diff mbox

[Fortran-CAF,committed] Add caf_send intrinsic

Message ID 532414C2.6080100@net-b.de
State New
Headers show

Commit Message

Tobias Burnus March 15, 2014, 8:52 a.m. UTC
The patch adds a new internal-only intrinsic "caf_send", which replaces 
assignments to coindexed variables, i.e.
     caf[i] = rhs
becomes
    _F.caf_send (caf[i], rhs, async=.false.)

The idea is that this replacement makes it easier to do optimizations in 
the front-end optimization pass (fortran/frontend-passes.c) - for 
instance, by turning the caf_send(...async=.false.) into a pair of 
async=.true. and a later wait.

In addition, it was the simplest way to divert the access into a 
dedicated function in trans-intrinsic.c

This patch only adds the intrinsic - and the (disabled, "false &&") 
replacement of the assignment by a the intrinsic call. The actual 
handling in trans-intrinsic.c is still missing. Teaser: I do have a 
working & tested patch, which implements the library call, but that 
patch still needs some clean up.

Committed to the Fortran-CAF branch as Rev. 208589

Tobias
diff mbox

Patch

Index: gfortran.h
===================================================================
--- gfortran.h	(Revision 208587)
+++ gfortran.h	(Arbeitskopie)
@@ -323,6 +323,7 @@  enum gfc_isym_id
   GFC_ISYM_CHDIR,
   GFC_ISYM_CHMOD,
   GFC_ISYM_CMPLX,
+  GFC_ISYM_CAF_SEND,
   GFC_ISYM_COMMAND_ARGUMENT_COUNT,
   GFC_ISYM_COMPILER_OPTIONS,
   GFC_ISYM_COMPILER_VERSION,
Index: intrinsic.c
===================================================================
--- intrinsic.c	(Revision 208587)
+++ intrinsic.c	(Arbeitskopie)
@@ -2756,7 +2756,7 @@  add_functions (void)
   make_generic ("size", GFC_ISYM_SIZE, GFC_STD_F95);
 
   /* 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,
 	     BT_INTEGER, gfc_index_integer_kind, GFC_STD_GNU,
 	     NULL, NULL, gfc_resolve_stride,
@@ -3209,6 +3209,16 @@  add_subroutines (void)
 	      "fptr", BT_UNKNOWN, 0, REQUIRED, INTENT_OUT);
   make_from_module();
 
+  /* The following function is internally used for coarray libray functions.
+     "make_from_module" makes it inaccessible for external users.  */
+  add_sym_3s (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,
+	      "async", BT_LOGICAL, dl,  REQUIRED, INTENT_IN);
+  make_from_module();
+
+
   /* More G77 compatibility garbage.  */
   add_sym_3s ("alarm", GFC_ISYM_ALARM, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
 	      gfc_check_alarm_sub, NULL, gfc_resolve_alarm_sub,
Index: resolve.c
===================================================================
--- resolve.c	(Revision 208587)
+++ resolve.c	(Arbeitskopie)
@@ -9217,8 +9217,10 @@  resolve_ordinary_assign (gfc_code *code, gfc_names
       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);
@@ -9226,6 +9228,28 @@  resolve_ordinary_assign (gfc_code *code, gfc_names
     }
 
   gfc_check_assign (lhs, rhs, 1);
+
+  if (false && 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->ext.actual->next->next = gfc_get_actual_arglist ();
+      code->ext.actual->next->next->expr =
+		gfc_get_logical_expr (gfc_default_logical_kind, NULL, false);
+      code->expr1 = NULL;
+      code->expr2 = NULL;
+    }
+
   return false;
 }
 
@@ -9861,7 +9885,7 @@  resolve_code (gfc_code *code, gfc_namespace *ns)
 	    }
 
 	  /* 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);