From 0e1f8c6a90834987f63f911a86d78e40d5577e80 Mon Sep 17 00:00:00 2001 From: Mikael Morin Date: Fri, 17 Jul 2015 09:40:29 +0000 Subject: [PATCH] Fix PR61831: Side-effect variable component deallocation gcc/fortran/ 2015-07-17 Mikael Morin Dominique d'Humieres PR fortran/61831 * trans-array.c (gfc_conv_array_parameter): Guard allocatable component deallocation code generation with descriptorless calling convention flag. * trans-expr.c (gfc_conv_expr_reference): Remove allocatable component deallocation code generation from revision 212329. (expr_may_alias_variables): New function. (gfc_conv_procedure_call): New boolean elemental_proc to factor check for procedure elemental-ness. Rename boolean f to nodesc_arg and declare it in the outer scope. Use expr_may_alias_variables, elemental_proc and nodesc_arg to decide whether generate allocatable component deallocation code. (gfc_trans_subarray_assign): Set deep copy flag. gcc/testsuite/ 2015-07-17 Mikael Morin PR fortran/61831 * gfortran.dg/alloc_comp_auto_array_3.f90: Count the number of generated while loops in the tree dump. * gfortran.dg/derived_constructor_comps_6.f90: New file. Co-Authored-By: Dominique d'Humieres From-SVN: r225926 --- gcc/fortran/ChangeLog | 17 +++ gcc/fortran/trans-array.c | 9 +- gcc/fortran/trans-expr.c | 137 ++++++++++++------ gcc/testsuite/ChangeLog | 7 + .../gfortran.dg/alloc_comp_auto_array_3.f90 | 1 + .../derived_constructor_comps_6.f90 | 133 +++++++++++++++++ 6 files changed, 258 insertions(+), 46 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/derived_constructor_comps_6.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index a3fd6debb3b..af81bd543f9 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,20 @@ +2015-07-17 Mikael Morin + Dominique d'Humieres + + PR fortran/61831 + * trans-array.c (gfc_conv_array_parameter): Guard allocatable + component deallocation code generation with descriptorless + calling convention flag. + * trans-expr.c (gfc_conv_expr_reference): Remove allocatable + component deallocation code generation from revision 212329. + (expr_may_alias_variables): New function. + (gfc_conv_procedure_call): New boolean elemental_proc to factor + check for procedure elemental-ness. Rename boolean f to nodesc_arg + and declare it in the outer scope. Use expr_may_alias_variables, + elemental_proc and nodesc_arg to decide whether generate allocatable + component deallocation code. + (gfc_trans_subarray_assign): Set deep copy flag. + 2015-07-16 Steven G. Kargl PR fortran/66724 diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index a520f03ddf7..1d5ddd0b68d 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -7395,10 +7395,11 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, bool g77, } /* Deallocate the allocatable components of structures that are - not variable. */ - if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS) - && expr->ts.u.derived->attr.alloc_comp - && expr->expr_type != EXPR_VARIABLE) + not variable, for descriptorless arguments. + Arguments with a descriptor are handled in gfc_conv_procedure_call. */ + if (g77 && (expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS) + && expr->ts.u.derived->attr.alloc_comp + && expr->expr_type != EXPR_VARIABLE) { tmp = build_fold_indirect_ref_loc (input_location, se->expr); tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index adc5c0aabe8..caafe7672e8 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4528,6 +4528,62 @@ conv_arglist_function (gfc_se *se, gfc_expr *expr, const char *name) } +/* This function tells whether the middle-end representation of the expression + E given as input may point to data otherwise accessible through a variable + (sub-)reference. + It is assumed that the only expressions that may alias are variables, + and array constructors if ARRAY_MAY_ALIAS is true and some of its elements + may alias. + This function is used to decide whether freeing an expression's allocatable + components is safe or should be avoided. + + If ARRAY_MAY_ALIAS is true, an array constructor may alias if some of + its elements are copied from a variable. This ARRAY_MAY_ALIAS trick + is necessary because for array constructors, aliasing depends on how + the array is used: + - If E is an array constructor used as argument to an elemental procedure, + the array, which is generated through shallow copy by the scalarizer, + is used directly and can alias the expressions it was copied from. + - If E is an array constructor used as argument to a non-elemental + procedure,the scalarizer is used in gfc_conv_expr_descriptor to generate + the array as in the previous case, but then that array is used + to initialize a new descriptor through deep copy. There is no alias + possible in that case. + Thus, the ARRAY_MAY_ALIAS flag is necessary to distinguish the two cases + above. */ + +static bool +expr_may_alias_variables (gfc_expr *e, bool array_may_alias) +{ + gfc_constructor *c; + + if (e->expr_type == EXPR_VARIABLE) + return true; + else if (e->expr_type == EXPR_FUNCTION) + { + gfc_symbol *proc_ifc = gfc_get_proc_ifc_for_expr (e); + + if ((proc_ifc->result->ts.type == BT_CLASS + && proc_ifc->result->ts.u.derived->attr.is_class + && CLASS_DATA (proc_ifc->result)->attr.class_pointer) + || proc_ifc->result->attr.pointer) + return true; + else + return false; + } + else if (e->expr_type != EXPR_ARRAY || !array_may_alias) + return false; + + for (c = gfc_constructor_first (e->value.constructor); + c; c = gfc_constructor_next (c)) + if (c->expr + && expr_may_alias_variables (c->expr, array_may_alias)) + return true; + + return false; +} + + /* Generate code for a procedure call. Note can return se->post != NULL. If se->direct_byref is set then se->expr contains the return parameter. Return nonzero, if the call has alternate specifiers. @@ -4580,9 +4636,15 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, comp = gfc_get_proc_ptr_comp (expr); + bool elemental_proc = (comp + && comp->ts.interface + && comp->ts.interface->attr.elemental) + || (comp && comp->attr.elemental) + || sym->attr.elemental; + if (se->ss != NULL) { - if (!sym->attr.elemental && !(comp && comp->attr.elemental)) + if (!elemental_proc) { gcc_assert (se->ss->info->type == GFC_SS_FUNCTION); if (se->ss->info->useflags) @@ -4639,6 +4701,23 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, fsym = formal ? formal->sym : NULL; parm_kind = MISSING; + /* If the procedure requires an explicit interface, the actual + argument is passed according to the corresponding formal + argument. If the corresponding formal argument is a POINTER, + ALLOCATABLE or assumed shape, we do not use g77's calling + convention, and pass the address of the array descriptor + instead. Otherwise we use g77's calling convention, in other words + pass the array data pointer without descriptor. */ + bool nodesc_arg = fsym != NULL + && !(fsym->attr.pointer || fsym->attr.allocatable) + && fsym->as + && fsym->as->type != AS_ASSUMED_SHAPE + && fsym->as->type != AS_ASSUMED_RANK; + if (comp) + nodesc_arg = nodesc_arg || !comp->attr.always_explicit; + else + nodesc_arg = nodesc_arg || !sym->attr.always_explicit; + /* Class array expressions are sometimes coming completely unadorned with either arrayspec or _data component. Correct that here. OOP-TODO: Move this to the frontend. */ @@ -5165,22 +5244,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, } else { - /* If the procedure requires an explicit interface, the actual - argument is passed according to the corresponding formal - argument. If the corresponding formal argument is a POINTER, - ALLOCATABLE or assumed shape, we do not use g77's calling - convention, and pass the address of the array descriptor - instead. Otherwise we use g77's calling convention. */ - bool f; - f = (fsym != NULL) - && !(fsym->attr.pointer || fsym->attr.allocatable) - && fsym->as && fsym->as->type != AS_ASSUMED_SHAPE - && fsym->as->type != AS_ASSUMED_RANK; - if (comp) - f = f || !comp->attr.always_explicit; - else - f = f || !sym->attr.always_explicit; - /* If the argument is a function call that may not create a temporary for the result, we have to check that we can do it, i.e. that there is no alias between this @@ -5225,7 +5288,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, array of derived types. In this case, the argument is converted to a temporary, which is passed and then written back after the procedure call. */ - gfc_conv_subref_array_arg (&parmse, e, f, + gfc_conv_subref_array_arg (&parmse, e, nodesc_arg, fsym ? fsym->attr.intent : INTENT_INOUT, fsym && fsym->attr.pointer); else if (gfc_is_class_array_ref (e, NULL) @@ -5237,7 +5300,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, OOP-TODO: Insert code so that if the dynamic type is the same as the declared type, copy-in/copy-out does not occur. */ - gfc_conv_subref_array_arg (&parmse, e, f, + gfc_conv_subref_array_arg (&parmse, e, nodesc_arg, fsym ? fsym->attr.intent : INTENT_INOUT, fsym && fsym->attr.pointer); @@ -5248,12 +5311,13 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, intent in. */ { e->must_finalize = 1; - gfc_conv_subref_array_arg (&parmse, e, f, + gfc_conv_subref_array_arg (&parmse, e, nodesc_arg, INTENT_IN, fsym && fsym->attr.pointer); } else - gfc_conv_array_parameter (&parmse, e, f, fsym, sym->name, NULL); + gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym, + sym->name, NULL); /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is allocated on entry, it must be deallocated. */ @@ -5295,7 +5359,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, but do not always set fsym. */ if (e->expr_type == EXPR_VARIABLE && e->symtree->n.sym->attr.optional - && ((e->rank != 0 && sym->attr.elemental) + && ((e->rank != 0 && elemental_proc) || e->representation.length || e->ts.type == BT_CHARACTER || (e->rank != 0 && (fsym == NULL @@ -5330,13 +5394,16 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_add_block_to_block (&post, &parmse.post); /* Allocated allocatable components of derived types must be - deallocated for non-variable scalars. Non-variable arrays are - dealt with in trans-array.c(gfc_conv_array_parameter). */ + deallocated for non-variable scalars, array arguments to elemental + procedures, and array arguments with descriptor to non-elemental + procedures. As bounds information for descriptorless arrays is no + longer available here, they are dealt with in trans-array.c + (gfc_conv_array_parameter). */ if (e && (e->ts.type == BT_DERIVED || e->ts.type == BT_CLASS) && e->ts.u.derived->attr.alloc_comp - && !(e->symtree && e->symtree->n.sym->attr.pointer) - && e->expr_type != EXPR_VARIABLE && !e->rank) - { + && (e->rank == 0 || elemental_proc || !nodesc_arg) + && !expr_may_alias_variables (e, elemental_proc)) + { int parm_rank; /* It is known the e returns a structure type with at least one allocatable component. When e is a function, ensure that the @@ -6674,7 +6741,7 @@ gfc_trans_subarray_assign (tree dest, gfc_component * cm, gfc_expr * expr) gfc_conv_expr (&rse, expr); - tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, false, true); + tmp = gfc_trans_scalar_assign (&lse, &rse, cm->ts, true, true, true); gfc_add_expr_to_block (&body, tmp); gcc_assert (rse.ss == gfc_ss_terminator); @@ -7545,20 +7612,6 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr) /* Take the address of that value. */ se->expr = gfc_build_addr_expr (NULL_TREE, var); - if (expr->ts.type == BT_DERIVED && expr->rank - && !gfc_is_finalizable (expr->ts.u.derived, NULL) - && expr->ts.u.derived->attr.alloc_comp - && expr->expr_type != EXPR_VARIABLE) - { - tree tmp; - - tmp = build_fold_indirect_ref_loc (input_location, se->expr); - tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, expr->rank); - - /* The components shall be deallocated before - their containing entity. */ - gfc_prepend_expr_to_block (&se->post, tmp); - } } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index bfa11ee4600..ccba51fb38a 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2015-07-17 Mikael Morin + + PR fortran/61831 + * gfortran.dg/alloc_comp_auto_array_3.f90: Count the number + of generated while loops in the tree dump. + * gfortran.dg/derived_constructor_components_6.f90: New file. + 2015-07-17 Yuri Rumyantsev * gcc.dg/vect/vect-outer-simd-2.c: New test. diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_auto_array_3.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_auto_array_3.f90 index eaeaf54b470..b135d3d56e4 100644 --- a/gcc/testsuite/gfortran.dg/alloc_comp_auto_array_3.f90 +++ b/gcc/testsuite/gfortran.dg/alloc_comp_auto_array_3.f90 @@ -27,3 +27,4 @@ contains end ! { dg-final { scan-tree-dump-times "builtin_malloc" 3 "original" } } ! { dg-final { scan-tree-dump-times "builtin_free" 4 "original" } } +! { dg-final { scan-tree-dump-times "while \\(1\\)" 4 "original" } } diff --git a/gcc/testsuite/gfortran.dg/derived_constructor_comps_6.f90 b/gcc/testsuite/gfortran.dg/derived_constructor_comps_6.f90 new file mode 100644 index 00000000000..f9fbcb15145 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/derived_constructor_comps_6.f90 @@ -0,0 +1,133 @@ +! { dg-do run } +! { dg-additional-options "-fsanitize=address -fdump-tree-original" +! +! PR fortran/61831 +! The deallocation of components of array constructor elements +! used to have the side effect of also deallocating some other +! variable's components from which they were copied. + +program main + implicit none + + integer, parameter :: n = 2 + + type :: string_t + character(LEN=1), dimension(:), allocatable :: chars + end type string_t + + type :: string_container_t + type(string_t) :: comp + end type string_container_t + + type :: string_array_container_t + type(string_t) :: comp(n) + end type string_array_container_t + + type(string_t) :: prt_in, tmp, tmpa(n) + type(string_container_t) :: tmpc, tmpca(n) + type(string_array_container_t) :: tmpac, tmpaca(n) + integer :: i, j, k + + do i=1,16 + + ! Test without intermediary function + prt_in = string_t(["A"]) + if (.not. allocated(prt_in%chars)) call abort + if (any(prt_in%chars .ne. "A")) call abort + deallocate (prt_in%chars) + + ! scalar elemental function + prt_in = string_t(["B"]) + if (.not. allocated(prt_in%chars)) call abort + if (any(prt_in%chars .ne. "B")) call abort + tmp = new_prt_spec (prt_in) + if (.not. allocated(prt_in%chars)) call abort + if (any(prt_in%chars .ne. "B")) call abort + deallocate (prt_in%chars) + deallocate (tmp%chars) + + ! array elemental function with array constructor + prt_in = string_t(["C"]) + if (.not. allocated(prt_in%chars)) call abort + if (any(prt_in%chars .ne. "C")) call abort + tmpa = new_prt_spec ([(prt_in, i=1,2)]) + if (.not. allocated(prt_in%chars)) call abort + if (any(prt_in%chars .ne. "C")) call abort + deallocate (prt_in%chars) + do j=1,n + deallocate (tmpa(j)%chars) + end do + + ! scalar elemental function with structure constructor + prt_in = string_t(["D"]) + if (.not. allocated(prt_in%chars)) call abort + if (any(prt_in%chars .ne. "D")) call abort + tmpc = new_prt_spec2 (string_container_t(prt_in)) + if (.not. allocated(prt_in%chars)) call abort + if (any(prt_in%chars .ne. "D")) call abort + deallocate (prt_in%chars) + deallocate(tmpc%comp%chars) + + ! array elemental function of an array constructor of structure constructors + prt_in = string_t(["E"]) + if (.not. allocated(prt_in%chars)) call abort + if (any(prt_in%chars .ne. "E")) call abort + tmpca = new_prt_spec2 ([ (string_container_t(prt_in), i=1,2) ]) + if (.not. allocated(prt_in%chars)) call abort + if (any(prt_in%chars .ne. "E")) call abort + deallocate (prt_in%chars) + do j=1,n + deallocate (tmpca(j)%comp%chars) + end do + + ! scalar elemental function with a structure constructor and a nested array constructor + prt_in = string_t(["F"]) + if (.not. allocated(prt_in%chars)) call abort + if (any(prt_in%chars .ne. "F")) call abort + tmpac = new_prt_spec3 (string_array_container_t([ (prt_in, i=1,2) ])) + if (.not. allocated(prt_in%chars)) call abort + if (any(prt_in%chars .ne. "F")) call abort + deallocate (prt_in%chars) + do j=1,n + deallocate (tmpac%comp(j)%chars) + end do + + ! array elemental function with an array constructor nested inside + ! a structure constructor nested inside an array constructor + prt_in = string_t(["G"]) + if (.not. allocated(prt_in%chars)) call abort + if (any(prt_in%chars .ne. "G")) call abort + tmpaca = new_prt_spec3 ([ (string_array_container_t([ (prt_in, i=1,2) ]), j=1,2) ]) + if (.not. allocated(prt_in%chars)) call abort + if (any(prt_in%chars .ne. "G")) call abort + deallocate (prt_in%chars) + do j=1,n + do k=1,n + deallocate (tmpaca(j)%comp(k)%chars) + end do + end do + + end do + +contains + + elemental function new_prt_spec (name) result (prt_spec) + type(string_t), intent(in) :: name + type(string_t) :: prt_spec + prt_spec = name + end function new_prt_spec + + elemental function new_prt_spec2 (name) result (prt_spec) + type(string_container_t), intent(in) :: name + type(string_container_t) :: prt_spec + prt_spec = name + end function new_prt_spec2 + + elemental function new_prt_spec3 (name) result (prt_spec) + type(string_array_container_t), intent(in) :: name + type(string_array_container_t) :: prt_spec + prt_spec = name + end function new_prt_spec3 +end program main +! { dg-final { scan-tree-dump-times "__builtin_malloc" 15 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_free" 33 "original" } } -- 2.30.2