Hi Paul,
thanks for the review. Commited as r232876.
Regards,
Andre
On Tue, 26 Jan 2016 18:36:28 +0100
Paul Richard Thomas <paul.richard.tho...@gmail.com> wrote:
> Dear Andre,
>
> The patch looks fine to me. OK for 5-branch.
>
> Thanks for the patch.
>
> Paul
>
> On 26 January 2016 at 13:28, Andre Vehreschild <ve...@gmx.de> wrote:
> > Hi all,
> >
> > please find attached a patch to solve the issue of evaluating a source=
> > expression of an allocate() twice in gcc-5. The patch is a combination
> > and partial back port of several prs of the mainline (namely, but not
> > the complete list: pr44672, pr65548).
> >
> > The patch needed the counts of builtin_mallocs/frees in
> > allocatable_scalar_13 to be adapted. There are now fewer calls to the
> > memory management routines. Valgrind does not report any memory issues
> > in the modified code, but that does not mean there aren't any. I am
> > happy to hear about any issue, this patch causes (still having issues
> > getting the sanitizer to work).
> >
> > Bootstrapped and regtested on x86_64-linux-gnu/F23.
> >
> > Ok, for gcc-5-branch?
> >
> > Regards,
> > Andre
> > --
> > Andre Vehreschild * Email: vehre ad gmx dot de
>
>
>
--
Andre Vehreschild * Email: vehre ad gmx dot de
Index: gcc/fortran/ChangeLog
===================================================================
--- gcc/fortran/ChangeLog (Revision 232870)
+++ gcc/fortran/ChangeLog (Arbeitskopie)
@@ -1,3 +1,11 @@
+2016-01-27 Andre Vehreschild <ve...@gcc.gnu.org>
+
+ PR fortran/p69268
+ * trans-stmt.c (gfc_trans_allocate): Make sure the source=
+ expression is evaluated once only. Use gfc_trans_assignment ()
+ instead of explicitly calling gfc_trans_string_copy () to
+ reduce the code complexity in trans_allocate.
+
2016-01-25 Dominique d'Humieres <domi...@lps.ens.fr>
PR fortran/68283
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (Revision 232870)
+++ gcc/fortran/trans-stmt.c (Arbeitskopie)
@@ -5108,7 +5108,7 @@
gfc_trans_allocate (gfc_code * code)
{
gfc_alloc *al;
- gfc_expr *expr;
+ gfc_expr *expr, *e3rhs = NULL;
gfc_se se, se_sz;
tree tmp;
tree parm;
@@ -5130,6 +5130,7 @@
stmtblock_t post;
tree nelems;
bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set;
+ gfc_symtree *newsym = NULL;
if (!code->ext.alloc.list)
return NULL_TREE;
@@ -5239,16 +5240,28 @@
false, false);
gfc_add_block_to_block (&block, &se.pre);
gfc_add_block_to_block (&post, &se.post);
- /* Prevent aliasing, i.e., se.expr may be already a
- variable declaration. */
+
if (!VAR_P (se.expr))
{
+ tree var;
+
tmp = build_fold_indirect_ref_loc (input_location,
se.expr);
- tmp = gfc_evaluate_now (tmp, &block);
+
+ /* We need a regular (non-UID) symbol here, therefore give a
+ prefix. */
+ var = gfc_create_var (TREE_TYPE (tmp), "source");
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+ {
+ gfc_allocate_lang_decl (var);
+ GFC_DECL_SAVED_DESCRIPTOR (var) = GFC_DECL_SAVED_DESCRIPTOR (tmp);
+ }
+ gfc_add_modify_loc (input_location, &block, var, tmp);
+ tmp = var;
}
else
tmp = se.expr;
+
if (!code->expr3->mold)
expr3 = tmp;
else
@@ -5357,6 +5370,71 @@
else
expr3_esize = TYPE_SIZE_UNIT (
gfc_typenode_for_spec (&code->expr3->ts));
+
+ /* The routine gfc_trans_assignment () already implements all
+ techniques needed. Unfortunately we may have a temporary
+ variable for the source= expression here. When that is the
+ case convert this variable into a temporary gfc_expr of type
+ EXPR_VARIABLE and used it as rhs for the assignment. The
+ advantage is, that we get scalarizer support for free,
+ don't have to take care about scalar to array treatment and
+ will benefit of every enhancements gfc_trans_assignment ()
+ gets.
+ Exclude variables since the following block does not handle
+ array sections. In any case, there is no harm in sending
+ variables to gfc_trans_assignment because there is no
+ evaluation of variables. */
+ if (code->expr3->expr_type != EXPR_VARIABLE
+ && code->expr3->mold != 1 && expr3 != NULL_TREE
+ && DECL_P (expr3) && DECL_ARTIFICIAL (expr3))
+ {
+ /* Build a temporary symtree and symbol. Do not add it to
+ the current namespace to prevent accidently modifying
+ a colliding symbol's as. */
+ newsym = XCNEW (gfc_symtree);
+ /* The name of the symtree should be unique, because
+ gfc_create_var () took care about generating the
+ identifier. */
+ newsym->name = gfc_get_string (IDENTIFIER_POINTER (
+ DECL_NAME (expr3)));
+ newsym->n.sym = gfc_new_symbol (newsym->name, NULL);
+ /* The backend_decl is known. It is expr3, which is inserted
+ here. */
+ newsym->n.sym->backend_decl = expr3;
+ e3rhs = gfc_get_expr ();
+ e3rhs->ts = code->expr3->ts;
+ e3rhs->rank = code->expr3->rank;
+ e3rhs->symtree = newsym;
+ /* Mark the symbol referenced or gfc_trans_assignment will
+ bug. */
+ newsym->n.sym->attr.referenced = 1;
+ e3rhs->expr_type = EXPR_VARIABLE;
+ e3rhs->where = code->expr3->where;
+ /* Set the symbols type, upto it was BT_UNKNOWN. */
+ newsym->n.sym->ts = e3rhs->ts;
+ /* Check whether the expr3 is array valued. */
+ if (e3rhs->rank)
+ {
+ gfc_array_spec *arr;
+ arr = gfc_get_array_spec ();
+ arr->rank = e3rhs->rank;
+ arr->type = AS_DEFERRED;
+ /* Set the dimension and pointer attribute for arrays
+ to be on the safe side. */
+ newsym->n.sym->attr.dimension = 1;
+ newsym->n.sym->attr.pointer = 1;
+ newsym->n.sym->as = arr;
+ gfc_add_full_array_ref (e3rhs, arr);
+ }
+ else if (POINTER_TYPE_P (TREE_TYPE (expr3)))
+ newsym->n.sym->attr.pointer = 1;
+ /* The string length is known to. Set it for char arrays. */
+ if (e3rhs->ts.type == BT_CHARACTER)
+ newsym->n.sym->ts.u.cl->backend_decl = expr3_len;
+ gfc_commit_symbol (newsym->n.sym);
+ }
+ else
+ e3rhs = gfc_copy_expr (code->expr3);
}
gcc_assert (expr3_esize);
expr3_esize = fold_convert (sizetype, expr3_esize);
@@ -5674,7 +5752,6 @@
{
/* Initialization via SOURCE block
(or static default initializer). */
- gfc_expr *rhs = gfc_copy_expr (code->expr3);
if (expr3 != NULL_TREE
&& ((POINTER_TYPE_P (TREE_TYPE (expr3))
&& TREE_CODE (expr3) != POINTER_PLUS_EXPR)
@@ -5688,19 +5765,6 @@
tmp = gfc_copy_class_to_class (expr3, to,
nelems, upoly_expr);
}
- else if (code->expr3->ts.type == BT_CHARACTER
- && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)))
- {
- tmp = INDIRECT_REF_P (se.expr) ?
- se.expr :
- build_fold_indirect_ref_loc (input_location,
- se.expr);
- gfc_trans_string_copy (&block, al_len, tmp,
- code->expr3->ts.kind,
- expr3_len, expr3,
- code->expr3->ts.kind);
- tmp = NULL_TREE;
- }
else if (al->expr->ts.type == BT_CLASS)
{
gfc_actual_arglist *actual, *last_arg;
@@ -5707,6 +5771,7 @@
gfc_expr *ppc;
gfc_code *ppc_code;
gfc_ref *ref, *dataref;
+ gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3);
/* Do a polymorphic deep copy. */
actual = gfc_get_actual_arglist ();
@@ -5818,6 +5883,8 @@
void_type_node, tmp, extcopy, stdcopy);
}
gfc_free_statements (ppc_code);
+ if (rhs != e3rhs)
+ gfc_free_expr (rhs);
}
else
{
@@ -5826,10 +5893,9 @@
int realloc_lhs = flag_realloc_lhs;
flag_realloc_lhs = 0;
tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr),
- rhs, false, false);
+ e3rhs, false, false);
flag_realloc_lhs = realloc_lhs;
}
- gfc_free_expr (rhs);
gfc_add_expr_to_block (&block, tmp);
}
else if (code->expr3 && code->expr3->mold
@@ -5847,6 +5913,15 @@
gfc_free_expr (expr);
} // for-loop
+ if (e3rhs)
+ {
+ if (newsym)
+ {
+ gfc_free_symbol (newsym->n.sym);
+ XDELETE (newsym);
+ }
+ gfc_free_expr (e3rhs);
+ }
/* STAT. */
if (code->expr1)
{
Index: gcc/testsuite/ChangeLog
===================================================================
--- gcc/testsuite/ChangeLog (Revision 232870)
+++ gcc/testsuite/ChangeLog (Arbeitskopie)
@@ -1,3 +1,10 @@
+2016-01-27 Andre Vehreschild <ve...@gcc.gnu.org>
+
+ PR fortran/69268
+ * gfortran.dg/allocatable_scalar_13.f90: Fixing counts of malloc/
+ free to fit the actual number of calls.
+ * gfortran.dg/allocate_with_source_16.f90: New test.
+
2016-01-27 Tom de Vries <t...@codesourcery.com>
* gcc.dg/autopar/pr69110.c: Fix pass number.
Index: gcc/testsuite/gfortran.dg/allocatable_scalar_13.f90
===================================================================
--- gcc/testsuite/gfortran.dg/allocatable_scalar_13.f90 (Revision 232870)
+++ gcc/testsuite/gfortran.dg/allocatable_scalar_13.f90 (Arbeitskopie)
@@ -67,6 +67,6 @@
! allocate(res, source = arg) ! Caused an ICE
! end subroutine
end
-! { dg-final { scan-tree-dump-times "builtin_malloc" 15 "original" } }
-! { dg-final { scan-tree-dump-times "builtin_free" 17 "original" } }
+! { dg-final { scan-tree-dump-times "builtin_malloc" 16 "original" } }
+! { dg-final { scan-tree-dump-times "builtin_free" 16 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
Index: gcc/testsuite/gfortran.dg/allocate_with_source_16.f90
===================================================================
--- gcc/testsuite/gfortran.dg/allocate_with_source_16.f90 (nicht existent)
+++ gcc/testsuite/gfortran.dg/allocate_with_source_16.f90 (Arbeitskopie)
@@ -0,0 +1,26 @@
+!{ dg-do compile }
+! PR69268
+!
+! Contributed by Rich Townsend <towns...@astro.wisc.edu>
+
+program test_sourced_alloc
+
+ implicit none
+
+ type :: foo_t
+ end type foo_t
+
+ class(foo_t), allocatable :: f
+
+ allocate(f, SOURCE=f_func())
+
+contains
+
+ function f_func () result (f)
+ type(foo_t) :: f
+ integer, save :: c = 0
+ c = c + 1
+ if (c .gt. 1) call abort()
+ end function f_func
+
+end program test_sourced_alloc
