[Patch, Fortran] -fcoarray=lib - add registering calls for nonallocatable coarrays

[Tobias Burnus <burnus at net-b dot de>]

The following applies to -fcoarray=lib; for -fcoarray=single there 
should be no change.

The coarray communication library needs to know about the coarrays even 
before the function containing them has been invoked. Thus, the coarrays 
(of all translation units) need to be registered at start up.

This patch handles this by creating a _caf_init function with 
constructor attribute, which is nested in the the parent's procedure if 
the latter contains local nonallocatable (and thus: static/SAVE) 
coarrays variables.

At the same time, all (nonallocatable) coarrays have been turned into 
pointers - to allow the communication library to allocate the memory. 
This allows optimizations, e.g., by allocating in memory which is 
available for all images on the same node (cf. MPI_Alloc_mem).

Additionally, a "token" is saved with the coarray, which allows the 
coarray library to identify the coarray. In a simple implementation, it 
could simply use the base_addr of the coarray or enumerate them through.


Example: The small example program

------------- < test.f90 >-----------------
program caf_program
  integer :: a[*] = 7
  a = 8
end program caf_program
------------- </ test.f90 >-----------------

is turned into the following tree (-fdump-tree-original)

------------- < test.f90.003t.original >-----------------
_caf_init.1 ()
{
  a = (integer(kind=4) * restrict) _gfortran_caf_register (4, 0, 
&caf_token.0, 0B, 0B, 0);
  *a = 7;
}

caf_program ()
{
  static void * caf_token.0;
  static integer(kind=4) * restrict a;
  void _caf_init.1 (void);

  (integer(kind=4)) *a = 8;
}

main (integer(kind=4) argc, character(kind=1) * * argv)
{
  static integer(kind=4) options.2[8] = {68, 1023, 0, 0, 1, 1, 0, 1};

  _gfortran_caf_init (&argc, &argv, &_gfortran_caf_this_image, 
&_gfortran_caf_num_images);
  _gfortran_set_args (argc, argv);
  _gfortran_set_options (8, &options.2[0]);
  _gfortran_caf_sync_all (0B, 0);
  caf_program ();
  __sync_synchronize ();
  _gfortran_caf_finalize ();
  return 0;
}
------------- </ test.f90.003t.original >-----------------

Note: By construction, _gfortran_caf_register is called before 
_gfortran_caf_init; thus, the MPI library will be initialized by the 
first _gfortran_caf_register call, unless the program does not have any 
nonallocatable coarrays.

No test cases, but the ones in gfortran.dg/coarray/ should already test 
this functionality.

To be done in later patches:
- Coarrays declared in modules (module variables)
- Allocatable coarrays

Note: As constructors are never optimized away [unless they are 
pure/const], static coarrays and also uncalled functions containing 
static coarrays will not be optimized away. (Cf. PRs middle-end/49106 
and middle-end/49108.)

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

Tobias
2011-05-22  Tobias Burnus  <burnus@net-b.de>

	PR fortran/18918
	* trans-array.c (gfc_conv_array_ref): Handle pointer coarrays.
	* trans-decl.c (has_coarray_vars, caf_init_block,
	gfor_fndecl_caf_register): New file-global variables.
	(gfc_finish_var_decl): Make sure that coarrays in main are static.
	(gfc_build_qualified_array): Generate coarray token variable.
	(gfc_get_symbol_decl): Don't use a static initializer for coarrays.
	(gfc_build_builtin_function_decls): Set gfor_fndecl_caf_register.
	(gfc_trans_deferred_vars, gfc_emit_parameter_debug_info): Skip for
	static coarrays.
	(generate_local_decl): Check for local coarrays.
	(create_main_function): SYNC ALL before calling MAIN.
	(generate_coarray_sym_init): Register static coarray.
	(generate_coarray_init): Generate CAF registering constructor
	function.
	(gfc_generate_function_code): Call it, if needed, do not create
	cgraph twice.
	* trans-types.c (gfc_get_nodesc_array_type): Generate pointers for
	-fcoarray=lib.
	* trans.h (gfor_fndecl_caf_register): New variable.
	(lang_type): New element caf_token.
	(GFC_TYPE_ARRAY_CAF_TOKEN): New macro.

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 78d65a6..29c7f83 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -2623,6 +2623,10 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym,
   if (ar->dimen == 0)
     {
       gcc_assert (ar->codimen);
+      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 (TREE_TYPE (TREE_TYPE (se->expr)), se->expr);
       return;
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index d771484..5121a39 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -78,6 +78,12 @@ static gfc_namespace *module_namespace;
 static gfc_symbol* current_procedure_symbol = NULL;
 
 
+/* With -fcoarray=lib: For generating the registering call
+   of static coarrays.  */
+static bool has_coarray_vars;
+static stmtblock_t caf_init_block;
+
+
 /* List of static constructor functions.  */
 
 tree gfc_static_ctors;
@@ -114,6 +120,7 @@ tree gfor_fndecl_associated;
 /* Coarray run-time library function decls.  */
 tree gfor_fndecl_caf_init;
 tree gfor_fndecl_caf_finalize;
+tree gfor_fndecl_caf_register;
 tree gfor_fndecl_caf_critical;
 tree gfor_fndecl_caf_end_critical;
 tree gfor_fndecl_caf_sync_all;
@@ -566,7 +573,9 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)
      SAVE_EXPLICIT.  */
   if (!sym->attr.use_assoc
 	&& (sym->attr.save != SAVE_NONE || sym->attr.data
-	      || (sym->value && sym->ns->proc_name->attr.is_main_program)))
+	    || (sym->value && sym->ns->proc_name->attr.is_main_program)
+	    || (gfc_option.coarray == GFC_FCOARRAY_LIB
+		&& sym->attr.codimension && !sym->attr.allocatable)))
     TREE_STATIC (decl) = 1;
 
   if (sym->attr.volatile_)
@@ -745,6 +754,18 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
   nest = (procns->proc_name->backend_decl != current_function_decl)
 	 && !sym->attr.contained;
 
+  if (sym->attr.codimension && gfc_option.coarray == GFC_FCOARRAY_LIB
+      && GFC_TYPE_ARRAY_CAF_TOKEN (type) == NULL_TREE)
+    {
+      tree token;
+
+      token = gfc_create_var_np (pvoid_type_node, "caf_token");
+      GFC_TYPE_ARRAY_CAF_TOKEN (type) = token;
+      DECL_ARTIFICIAL (token) = 1;
+      TREE_STATIC (token) = 1;
+      gfc_add_decl_to_function (token);
+    }
+
   for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
     {
       if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
@@ -1403,7 +1424,8 @@ gfc_get_symbol_decl (gfc_symbol * sym)
       && !(sym->attr.use_assoc && !intrinsic_array_parameter)
       && (sym->attr.save || sym->ns->proc_name->attr.is_main_program
 	  || gfc_option.flag_max_stack_var_size == 0
-	  || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE))
+	  || sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE)
+      && (gfc_option.coarray != GFC_FCOARRAY_LIB || !sym->attr.codimension))
     {
       /* Add static initializer. For procedures, it is only needed if
 	 SAVE is specified otherwise they need to be reinitialized
@@ -3025,6 +3047,11 @@ gfc_build_builtin_function_decls (void)
       gfor_fndecl_caf_finalize = gfc_build_library_function_decl (
 	get_identifier (PREFIX("caf_finalize")), void_type_node, 0);
 
+      gfor_fndecl_caf_register = gfc_build_library_function_decl_with_spec (
+	get_identifier (PREFIX("caf_register")), "...WWW", pvoid_type_node, 6,
+        size_type_node, integer_type_node, ppvoid_type_node, pint_type,
+        build_pointer_type (pchar_type_node), integer_type_node);
+
       gfor_fndecl_caf_critical = gfc_build_library_function_decl (
 	get_identifier (PREFIX("caf_critical")), void_type_node, 0);
 
@@ -3458,7 +3485,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
 		      gfc_trans_deferred_array (sym, block);
 		    }
 		}
-	      else
+	      else if (gfc_option.coarray != GFC_FCOARRAY_LIB)
 		{
 		  gfc_save_backend_locus (&loc);
 		  gfc_set_backend_locus (&sym->declared_at);
@@ -4066,6 +4093,9 @@ gfc_emit_parameter_debug_info (gfc_symbol *sym)
 				   sym->attr.dimension, false))
     return;
 
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB && sym->attr.codimension)
+    return;
+
   /* Create the decl for the variable or constant.  */
   decl = build_decl (input_location,
 		     sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
@@ -4200,6 +4230,10 @@ generate_local_decl (gfc_symbol * sym)
 {
   if (sym->attr.flavor == FL_VARIABLE)
     {
+      if (sym->attr.codimension && !sym->attr.dummy && !sym->attr.allocatable
+	  && sym->attr.referenced)
+	has_coarray_vars = true;
+
       if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
 	generate_dependency_declarations (sym);
 
@@ -4826,6 +4860,116 @@ gfc_generate_return (void)
 }
 
 
+static void
+generate_coarray_sym_init (gfc_symbol *sym)
+{
+  tree tmp, size, decl, token;
+
+  if (sym->attr.dummy || sym->attr.allocatable || !sym->attr.codimension)
+    return;
+
+  if (!sym->attr.referenced)
+    return;
+
+  decl = sym->backend_decl;
+  TREE_USED(decl) = 1;
+  gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (decl)));
+
+  /* FIXME: Workaround for PR middle-end/49106, cf. also PR middle-end/49108
+     to make sure the variable is not optimized away.  */
+  DECL_PRESERVE_P (DECL_CONTEXT (decl)) = 1;
+
+  size = TYPE_SIZE_UNIT (gfc_get_element_type (TREE_TYPE (decl)));
+
+  if (GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)))
+    {
+      tmp = GFC_TYPE_ARRAY_SIZE (TREE_TYPE (decl));
+      size = fold_build2_loc (input_location, MULT_EXPR, size_type_node,
+			      fold_convert (size_type_node, tmp),
+			      fold_convert (size_type_node, size));
+    }
+
+  gcc_assert (GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (decl)) != NULL_TREE);
+  token = gfc_build_addr_expr (ppvoid_type_node,
+			       GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE(decl)));
+
+  tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_register, 6, size,
+			     build_int_cst (integer_type_node, 0), /* type.  */
+			     token, null_pointer_node, /* token, stat.  */
+			     null_pointer_node, /* errgmsg, errmsg_len.  */
+			     build_int_cst (integer_type_node, 0));
+  
+  gfc_add_modify (&caf_init_block, decl, fold_convert (TREE_TYPE (decl), tmp));
+
+
+  /* Handle "static" initializer.  */
+  if (sym->value)
+    {
+      sym->attr.pointer = 1;
+      tmp = gfc_trans_assignment (gfc_lval_expr_from_sym (sym), sym->value,
+				  true, false);
+      sym->attr.pointer = 0;
+      gfc_add_expr_to_block (&caf_init_block, tmp);
+    }
+}
+
+
+/* Generate constructor function to initialize static, nonallocatable
+   coarrays.  */
+
+static void
+generate_coarray_init (gfc_namespace * ns __attribute((unused)))
+{
+  tree fndecl, tmp, decl, save_fn_decl;
+
+  save_fn_decl = current_function_decl;
+  push_function_context ();
+
+  tmp = build_function_type_list (void_type_node, NULL_TREE);
+  fndecl = build_decl (input_location, FUNCTION_DECL,
+		       create_tmp_var_name ("_caf_init"), tmp);
+
+  DECL_STATIC_CONSTRUCTOR (fndecl) = 1;
+  SET_DECL_INIT_PRIORITY (fndecl, DEFAULT_INIT_PRIORITY);
+
+  decl = build_decl (input_location, RESULT_DECL, NULL_TREE, void_type_node);
+  DECL_ARTIFICIAL (decl) = 1;
+  DECL_IGNORED_P (decl) = 1;
+  DECL_CONTEXT (decl) = fndecl;
+  DECL_RESULT (fndecl) = decl;
+
+  pushdecl (fndecl);
+  current_function_decl = fndecl;
+  announce_function (fndecl);
+
+  rest_of_decl_compilation (fndecl, 0, 0);
+  make_decl_rtl (fndecl);
+  init_function_start (fndecl);
+
+  pushlevel (0);
+  gfc_init_block (&caf_init_block);
+
+  gfc_traverse_ns (ns, generate_coarray_sym_init);
+
+  DECL_SAVED_TREE (fndecl) = gfc_finish_block (&caf_init_block);
+  decl = getdecls ();
+
+  poplevel (1, 0, 1);
+  BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
+
+  DECL_SAVED_TREE (fndecl)
+    = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
+                DECL_INITIAL (fndecl));
+  dump_function (TDI_original, fndecl);
+
+  cfun->function_end_locus = input_location;
+  set_cfun (NULL);
+  (void) cgraph_create_node (fndecl);
+  pop_function_context ();
+  current_function_decl = save_fn_decl;
+}
+
+
 /* Generate code for a function.  */
 
 void
@@ -4897,8 +5041,12 @@ gfc_generate_function_code (gfc_namespace * ns)
   nonlocal_dummy_decls = NULL;
   nonlocal_dummy_decl_pset = NULL;
 
+  has_coarray_vars = false;
   generate_local_vars (ns);
 
+  if (gfc_option.coarray == GFC_FCOARRAY_LIB && has_coarray_vars)
+    generate_coarray_init (ns);
+
   /* Keep the parent fake result declaration in module functions
      or external procedures.  */
   if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
@@ -5062,9 +5210,13 @@ gfc_generate_function_code (gfc_namespace * ns)
     }
   current_function_decl = old_context;
 
-  if (decl_function_context (fndecl))
+  if (decl_function_context (fndecl) && !gfc_option.coarray == GFC_FCOARRAY_LIB
+      && has_coarray_vars)
     /* Register this function with cgraph just far enough to get it
-       added to our parent's nested function list.  */
+       added to our parent's nested function list.
+       If there are static coarrays in this function, the nested _caf_init
+       function has already called cgraph_create_node, which also created
+       the cgraph node for this function.  */
     (void) cgraph_create_node (fndecl);
   else
     cgraph_finalize_function (fndecl, true);
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index 1165926..9c4f5f6 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1542,13 +1542,13 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
 
   if (as->rank == 0)
     {
-      if (packed != PACKED_STATIC)
+      if (packed != PACKED_STATIC  || gfc_option.coarray == GFC_FCOARRAY_LIB)
 	type = build_pointer_type (type);
 
       if (restricted)
         type = build_qualified_type (type, TYPE_QUAL_RESTRICT);	
 
-      if (packed != PACKED_STATIC)
+      if (packed != PACKED_STATIC  || gfc_option.coarray == GFC_FCOARRAY_LIB)
 	{
 	  GFC_ARRAY_TYPE_P (type) = 1;
 	  TYPE_LANG_SPECIFIC (type) = TYPE_LANG_SPECIFIC (TREE_TYPE (type)); 
@@ -1596,7 +1596,8 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
       DECL_ORIGINAL_TYPE (type_decl) = gtype;
     }
 
-  if (packed != PACKED_STATIC || !known_stride)
+  if (packed != PACKED_STATIC || !known_stride
+      || (as->corank && gfc_option.coarray == GFC_FCOARRAY_LIB))
     {
       /* For dummy arrays and automatic (heap allocated) arrays we
 	 want a pointer to the array.  */
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 2b06d80..95cd9fb 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -617,6 +617,7 @@ extern GTY(()) tree gfor_fndecl_associated;
 /* Coarray run-time library function decls.  */
 extern GTY(()) tree gfor_fndecl_caf_init;
 extern GTY(()) tree gfor_fndecl_caf_finalize;
+extern GTY(()) tree gfor_fndecl_caf_register;
 extern GTY(()) tree gfor_fndecl_caf_critical;
 extern GTY(()) tree gfor_fndecl_caf_end_critical;
 extern GTY(()) tree gfor_fndecl_caf_sync_all;
@@ -722,6 +723,7 @@ struct GTY((variable_size))	lang_type	 {
   tree span;
   tree base_decl[2];
   tree nonrestricted_type;
+  tree caf_token;
 };
 
 struct GTY((variable_size)) lang_decl {
@@ -766,6 +768,7 @@ struct GTY((variable_size)) lang_decl {
   (TYPE_LANG_SPECIFIC(node)->stride[dim])
 #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_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)