[PATCH, Fortran, v1] Restructure initialization of allocatable components

[Andre Vehreschild <vehre@gmx.de>]

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

Hi all,

the attached patch restructures gfortran's way of initializing components of
derived types in ALLOCATE. The old way was to generate a new gfc_code-node and
add it after the ALLOCATE node to initialize the the derived type on certain
conditions (like initializer or allocatable components exist). This patch
proposes to do the initialization as part of the ALLOCATE. This way it makes the
ALLOCATE-statement more atomic in that the ALLOCATE does everything it is
responsible for itself and does rely on other nodes adding to its
responsibilities. The patch furthermore enables to use the knowledge we have in
the allocate, i.e., a freshly allocated object can never have allocated
allocatable components, so no need to check before resetting them.

At the same time I remove some dead code from the resolve_alloc_expr and moved
a loop invariant piece out of the loop iterating over all objects to allocate.
This of course is only cosmetic.

Of course did I not do this out of fun. I have a patch upcoming for allocatable
components in coarrayed derived types. For this I needed to identify the
initialization of the structure and to parameterize it further. This was hard
when for the default initialization an additional code-node was created, but
now that everything necessary for ALLOCATE is done in ALLOCATE parameterizing
the initialization is way easier. The coarray patch is not yet perfect, but I
thought to publish this part already to get your opinions.

Bootstraps and regtests fine on x86_64-linux/F23. Ok for trunk?

@Dominique: Would you give it a go on your open patch collection? Maybe it
fixes one PR, but I am not very hopeful, because the patch is merely removing
complexity instead of doing new things.

Regards,
	Andre
-- 
Andre Vehreschild * Email: vehre ad gmx dot de 

[-- Attachment #2: rework_derived_alloc.clog --]
[-- Type: application/octet-stream, Size: 1296 bytes --]

gcc/testsuite/ChangeLog:

2016-11-03  Andre Vehreschild  <vehre@gcc.gnu.org>

	* gfortran.dg/allocate_with_source_14.f03: Fixed number mallocs
	occuring.

gcc/fortran/ChangeLog:

2016-11-03  Andre Vehreschild  <vehre@gcc.gnu.org>

	* expr.c (is_non_empty_structure_constructor): New function to detect
	non-empty structure constructor.
	(gfc_has_default_initializer): Analyse initializers.
	* resolve.c (cond_init): Removed.
	(resolve_allocate_expr): Removed dead code.  Moved invariant code out
	of the loop over all objects to allocate.
	(resolve_allocate_deallocate): Added the invariant code remove from
	resolve_allocate_expr.
	* trans-array.c (gfc_array_allocate): Removed nullify of structure
	components in favour of doing this in gfc_trans_allocate for both
	scalars and arrays in the same place.
	* trans-expr.c (gfc_trans_init_assign): Always using _vptr->copy for
	class objects.
	* trans-stmt.c (allocate_get_initializer): Get the initializer
	expression for object allocated.
	(gfc_trans_allocate): Nullify a derived type only, when no SOURCE=
	or MOLD= is present preventing duplicate work.  Moved the creation
	of the init-expression here to prevent code for conditions that
	can not occur on freshly allocated object, like checking for the need
	to free allocatable components.


[-- Attachment #3: rework_derived_alloc.patch --]
[-- Type: text/x-patch, Size: 10023 bytes --]

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index bb183d4..0e94ae8 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -4131,6 +4131,26 @@ gfc_apply_init (gfc_typespec *ts, symbol_attribute *attr, gfc_expr *init)
 }
 
 
+/* Check whether an expression is a structure constructor and whether it has
+   other values than NULL.  */
+
+bool
+is_non_empty_structure_constructor (gfc_expr * e)
+{
+  if (e->expr_type != EXPR_STRUCTURE)
+    return false;
+
+  gfc_constructor *cons = gfc_constructor_first (e->value.constructor);
+  while (cons)
+    {
+      if (!cons->expr || cons->expr->expr_type != EXPR_NULL)
+	return true;
+      cons = gfc_constructor_next (cons);
+    }
+  return false;
+}
+
+
 /* Check for default initializer; sym->value is not enough
    as it is also set for EXPR_NULL of allocatables.  */
 
@@ -4145,7 +4165,9 @@ gfc_has_default_initializer (gfc_symbol *der)
       {
         if (!c->attr.pointer && !c->attr.proc_pointer
 	     && !(c->attr.allocatable && der == c->ts.u.derived)
-	     && gfc_has_default_initializer (c->ts.u.derived))
+	     && ((c->initializer
+		  && is_non_empty_structure_constructor (c->initializer))
+		 || gfc_has_default_initializer (c->ts.u.derived)))
 	  return true;
 	if (c->attr.pointer && c->initializer)
 	  return true;
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 14685d2..c341bbc 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -7046,35 +7046,6 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2)
   return true;
 }
 
-static void
-cond_init (gfc_code *code, gfc_expr *e, int pointer, gfc_expr *init_e)
-{
-  gfc_code *block;
-  gfc_expr *cond;
-  gfc_code *init_st;
-  gfc_expr *e_to_init = gfc_expr_to_initialize (e);
-
-  cond = pointer
-    ? gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_ASSOCIATED,
-	"associated", code->loc, 2, gfc_copy_expr (e_to_init), NULL)
-    : gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_ALLOCATED,
-	"allocated", code->loc, 1, gfc_copy_expr (e_to_init));
-
-  init_st = gfc_get_code (EXEC_INIT_ASSIGN);
-  init_st->loc = code->loc;
-  init_st->expr1 = e_to_init;
-  init_st->expr2 = init_e;
-
-  block = gfc_get_code (EXEC_IF);
-  block->loc = code->loc;
-  block->block = gfc_get_code (EXEC_IF);
-  block->block->loc = code->loc;
-  block->block->expr1 = cond;
-  block->block->next = init_st;
-  block->next = code->next;
-
-  code->next = block;
-}
 
 /* Resolve the expression in an ALLOCATE statement, doing the additional
    checks to see whether the expression is OK or not.  The expression must
@@ -7325,34 +7296,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
       /* We have to zero initialize the integer variable.  */
       code->expr3 = gfc_get_int_expr (gfc_default_integer_kind, &e->where, 0);
     }
-  else if (!code->expr3)
-    {
-      /* Set up default initializer if needed.  */
-      gfc_typespec ts;
-      gfc_expr *init_e;
-
-      if (gfc_bt_struct (code->ext.alloc.ts.type))
-	ts = code->ext.alloc.ts;
-      else
-	ts = e->ts;
-
-      if (ts.type == BT_CLASS)
-	ts = ts.u.derived->components->ts;
-
-      if (gfc_bt_struct (ts.type) && (init_e = gfc_default_initializer (&ts)))
-	cond_init (code, e, pointer, init_e);
-    }
-  else if (code->expr3->mold && code->expr3->ts.type == BT_DERIVED)
-    {
-      /* Default initialization via MOLD (non-polymorphic).  */
-      gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
-      if (rhs != NULL)
-	{
-	  gfc_resolve_expr (rhs);
-	  gfc_free_expr (code->expr3);
-	  code->expr3 = rhs;
-	}
-    }
 
   if (e->ts.type == BT_CLASS && !unlimited && !UNLIMITED_POLY (code->expr3))
     {
@@ -7364,10 +7307,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
       else if (code->ext.alloc.ts.type == BT_DERIVED)
 	ts = code->ext.alloc.ts;
 
+      /* Finding the vtab also publishes the type's symbol.  Therefore this
+	 statement is necessary.  */
       gfc_find_derived_vtab (ts.u.derived);
-
-      if (dimension)
-	e = gfc_expr_to_initialize (e);
     }
   else if (unlimited && !UNLIMITED_POLY (code->expr3))
     {
@@ -7381,10 +7323,9 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
 
       gcc_assert (ts);
 
+      /* Finding the vtab also publishes the type's symbol.  Therefore this
+	 statement is necessary.  */
       gfc_find_vtab (ts);
-
-      if (dimension)
-	e = gfc_expr_to_initialize (e);
     }
 
   if (dimension == 0 && codimension == 0)
@@ -7688,6 +7629,22 @@ resolve_allocate_deallocate (gfc_code *code, const char *fcn)
   if (strcmp (fcn, "ALLOCATE") == 0)
     {
       bool arr_alloc_wo_spec = false;
+
+      /* Resolving the expr3 in the loop over all objects to allocate would
+	 execute loop invariant code for each loop item.  Therefore do it just
+	 once here.  */
+      if (code->expr3 && code->expr3->mold
+	  && code->expr3->ts.type == BT_DERIVED)
+	{
+	  /* Default initialization via MOLD (non-polymorphic).  */
+	  gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
+	  if (rhs != NULL)
+	    {
+	      gfc_resolve_expr (rhs);
+	      gfc_free_expr (code->expr3);
+	      code->expr3 = rhs;
+	    }
+	}
       for (a = code->ext.alloc.list; a; a = a->next)
 	resolve_allocate_expr (a->expr, code, &arr_alloc_wo_spec);
 
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 74935b1..1708f7c 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -5623,14 +5623,6 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg,
   else
       gfc_add_expr_to_block (&se->pre, set_descriptor);
 
-  if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp
-      && !coarray)
-    {
-      tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr,
-				    ref->u.ar.as->rank);
-      gfc_add_expr_to_block (&se->pre, tmp);
-    }
-
   return true;
 }
 
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 7159b17..b5bcb22 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -10036,7 +10036,7 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
 tree
 gfc_trans_init_assign (gfc_code * code)
 {
-  return gfc_trans_assignment (code->expr1, code->expr2, true, false);
+  return gfc_trans_assignment (code->expr1, code->expr2, true, false, true);
 }
 
 tree
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index c52066f..490b18d 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -5450,13 +5450,41 @@ gfc_trans_exit (gfc_code * code)
 }
 
 
+/* Get the initializer expression for the code and expr of an allocate.
+   When no initializer is needed return NULL.  */
+
+static gfc_expr *
+allocate_get_initializer (gfc_code * code, gfc_expr * expr)
+{
+  if (!gfc_bt_struct (expr->ts.type) && expr->ts.type != BT_CLASS)
+    return NULL;
+
+  /* An explicit type was given in allocate ( T:: object).  */
+  if (code->ext.alloc.ts.type == BT_DERIVED
+      && (code->ext.alloc.ts.u.derived->attr.alloc_comp
+	  || gfc_has_default_initializer (code->ext.alloc.ts.u.derived)))
+    return gfc_default_initializer (&code->ext.alloc.ts);
+
+  if (gfc_bt_struct (expr->ts.type)
+      && (expr->ts.u.derived->attr.alloc_comp
+	  || gfc_has_default_initializer (expr->ts.u.derived)))
+    return gfc_default_initializer (&expr->ts);
+
+  if (expr->ts.type == BT_CLASS
+      && (CLASS_DATA (expr)->ts.u.derived->attr.alloc_comp
+	  || gfc_has_default_initializer (CLASS_DATA (expr)->ts.u.derived)))
+    return gfc_default_initializer (&CLASS_DATA (expr)->ts);
+
+  return NULL;
+}
+
 /* Translate the ALLOCATE statement.  */
 
 tree
 gfc_trans_allocate (gfc_code * code)
 {
   gfc_alloc *al;
-  gfc_expr *expr, *e3rhs = NULL;
+  gfc_expr *expr, *e3rhs = NULL, *init_expr;
   gfc_se se, se_sz;
   tree tmp;
   tree parm;
@@ -6080,14 +6108,6 @@ gfc_trans_allocate (gfc_code * code)
 				      label_finish, expr, 0);
 	  else
 	    gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat);
-
-	  if (al->expr->ts.type == BT_DERIVED
-	      && expr->ts.u.derived->attr.alloc_comp)
-	    {
-	      tmp = build_fold_indirect_ref_loc (input_location, se.expr);
-	      tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0);
-	      gfc_add_expr_to_block (&se.pre, tmp);
-	    }
 	}
       else
 	{
@@ -6217,6 +6237,8 @@ gfc_trans_allocate (gfc_code * code)
 			    fold_convert (TREE_TYPE (al_len),
 					  integer_zero_node));
 	}
+
+      init_expr = NULL;
       if (code->expr3 && !code->expr3->mold && e3_is != E3_MOLD)
 	{
 	  /* Initialization via SOURCE block (or static default initializer).
@@ -6246,6 +6268,23 @@ gfc_trans_allocate (gfc_code * code)
 	  gfc_free_statements (ini);
 	  gfc_add_expr_to_block (&block, tmp);
 	}
+      else if ((init_expr = allocate_get_initializer (code, expr)))
+	{
+	  /* Use class_init_assign to initialize expr.  */
+	  gfc_code *ini;
+	  int realloc_lhs = flag_realloc_lhs;
+	  ini = gfc_get_code (EXEC_INIT_ASSIGN);
+	  ini->expr1 = gfc_expr_to_initialize (expr);
+	  ini->expr2 = init_expr;
+	  flag_realloc_lhs = 0;
+	  tmp= gfc_trans_init_assign (ini);
+	  flag_realloc_lhs = realloc_lhs;
+	  gfc_free_statements (ini);
+	  /* Init_expr is freeed by above free_statements, just need to null
+	     it here.  */
+	  init_expr = NULL;
+	  gfc_add_expr_to_block (&block, tmp);
+	}
 
       gfc_free_expr (expr);
     } // for-loop
diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_14.f03 b/gcc/testsuite/gfortran.dg/allocate_with_source_14.f03
index 36c1245..fd2db74 100644
--- a/gcc/testsuite/gfortran.dg/allocate_with_source_14.f03
+++ b/gcc/testsuite/gfortran.dg/allocate_with_source_14.f03
@@ -210,5 +210,5 @@ program main
   call v%free()
   deallocate(av)
 end program
-! { dg-final { scan-tree-dump-times "__builtin_malloc" 23 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_malloc" 22 "original" } }
 ! { dg-final { scan-tree-dump-times "__builtin_free" 29 "original" } }