===================================================================
@@ -1,3 +1,26 @@
+2016-11-06 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.
+
2016-11-06 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/78221
===================================================================
@@ -4131,6 +4131,26 @@
}
+/* 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 @@
{
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;
===================================================================
@@ -7048,36 +7048,7 @@
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
have a trailing array reference that gives the size of the array. */
@@ -7327,35 +7298,7 @@
/* 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))
{
/* Make sure the vtab symbol is present when
@@ -7366,10 +7309,9 @@
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))
{
@@ -7383,10 +7325,9 @@
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)
@@ -7690,6 +7631,22 @@
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);
===================================================================
@@ -10042,7 +10042,7 @@
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
===================================================================
@@ -5623,14 +5623,6 @@
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;
}
===================================================================
@@ -5450,6 +5450,34 @@
}
+/* 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
@@ -5456,7 +5484,7 @@
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 @@
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 @@
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_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
===================================================================
@@ -210,5 +210,5 @@
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" } }
===================================================================
@@ -1,3 +1,8 @@
+2016-11-06 Andre Vehreschild <vehre@gcc.gnu.org>
+
+ * gfortran.dg/allocate_with_source_14.f03: Fixed number mallocs
+ occuring.
+
2016-11-06 Thomas Koenig <tkoenig@gcc.gnu.org>
PR fortran/78221