This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[Patch, fortran] PR41478 - Corrupted memory using PACK for derived-types with allocated components
- From: Paul Richard Thomas <paul dot richard dot thomas at gmail dot com>
- To: fortran at gcc dot gnu dot org, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Tue, 12 Jan 2010 22:10:49 +0100
- Subject: [Patch, fortran] PR41478 - Corrupted memory using PACK for derived-types with allocated components
The attached fixes the original problem and that of comment #8. The
latter involved the corrections for the copying of scalar components.
Unfortunately, problems still remain with allocatable scalar component
and I will turn to these next; eg. try anything involving derived type
allocatable scalar components that themselves have allocatable
components.
Bootstrapped and regtested on FC9/x86_64 - OK for trunk?
Paul
2010-01-12 Paul Thomas <pault@gcc.gnu.org>
PR fortran/41478
* trans-array.c (duplicate_allocatable): Static version of
gfc_duplicate_allocatable with provision to handle scalar
components. New boolean argument to switch off call to malloc
if true.
(gfc_duplicate_allocatable): New function to call above with
new argument false.
(gfc_copy_allocatable_data): New function to call above with
new argument true.
(structure_alloc_comps): Do not apply indirect reference to
scalar pointers. Add new section to copy allocatable components
of arrays. Extend copying of allocatable components to include
scalars.
(gfc_copy_only_alloc_comp): New function to copy allocatable
component derived types, without allocating the base structure.
* trans-array.h : Add primitive for gfc_copy_allocatable_data.
Add primitive for gfc_copy_only_alloc_comp.
* trans-expr.c (gfc_conv_procedure_call): After calls to
transformational functions with results that are derived types
with allocatable components, copy the components in the result.
(gfc_trans_arrayfunc_assign): Deallocate allocatable components
of lhs derived types before allocation.
2010-01-12 Paul Thomas <pault@gcc.gnu.org>
PR fortran/41478
* gfortran.dg/alloc_comp_scalar_1.f90: New test.
* gfortran.dg/alloc_comp_transformational_1.f90: New test.
Index: gcc/testsuite/gfortran.dg/alloc_comp_scalar_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/alloc_comp_scalar_1.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/alloc_comp_scalar_1.f90 (revision 0)
***************
*** 0 ****
--- 1,17 ----
+ ! { dg-do run }
+ ! Test the fix for comment #8 of PR41478, in which copying
+ ! allocatable scalar components caused a segfault.
+ !
+ ! Contributed by Tobias Burnus <burnus@gcc.gnu.org>
+ !
+ program main
+ type :: container_t
+ integer, allocatable :: entry
+ end type container_t
+ type(container_t), dimension(1) :: a1, a2
+ allocate (a1(1)%entry, a2(1)%entry)
+ a2(1)%entry = 1
+ a1(1:1) = pack (a2(1:1), mask = [.true.])
+ deallocate (a2(1)%entry)
+ if (a1(1)%entry .ne. 1) call abort
+ end program main
Index: gcc/testsuite/gfortran.dg/alloc_comp_transformational_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/alloc_comp_transformational_1.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/alloc_comp_transformational_1.f90 (revision 0)
***************
*** 0 ****
--- 1,80 ----
+ ! { dg-do run }
+ ! Tests the fix for PR41478, in which double frees would occur because
+ ! transformational intrinsics did not copy the allocatable components
+ ! so that they were (sometimes) freed twice on exit. In addition,
+ ! The original allocatable components of a1 were not freed, so that
+ ! memory leakage occurred.
+ !
+ ! Contributed by Juergen Reuter <reuter@physik.uni-freiburg.de>
+ !
+ type :: container_t
+ integer, dimension(:), allocatable :: entry
+ integer index
+ end type container_t
+ call foo
+ call bar
+ contains
+ !
+ ! This is the reported problem.
+ !
+ subroutine foo
+ type(container_t), dimension(4) :: a1, a2, a3
+ integer :: i
+ do i = 1, 4
+ allocate (a1(i)%entry (2), a2(i)%entry (2), a3(i)%entry (2))
+ a1(i)%entry = [1,2]
+ a2(i)%entry = [3,4]
+ a3(i)%entry = [4,5]
+ a1(i)%index = i
+ a2(i)%index = i
+ a3(i)%index = i
+ end do
+ a1(1:2) = pack (a2, [.true., .false., .true., .false.])
+ do i = 1, 4
+ if (.not.allocated (a1(i)%entry)) call abort
+ if (i .gt. 2) then
+ if (any (a1(i)%entry .ne. [1,2])) call abort
+ else
+ if (any (a1(i)%entry .ne. [3,4])) call abort
+ end if
+ end do
+ !
+ ! Now check unpack
+ !
+ a1 = unpack (a1, [.true., .true., .false., .false.], a3)
+ if (any (a1%index .ne. [1,3,3,4])) call abort
+ do i = 1, 4
+ if (.not.allocated (a1(i)%entry)) call abort
+ if (i .gt. 2) then
+ if (any (a1(i)%entry .ne. [4,5])) call abort
+ else
+ if (any (a1(i)%entry .ne. [3,4])) call abort
+ end if
+ end do
+ end subroutine
+ !
+ ! Other all transformational intrinsics display it. Having done
+ ! PACK and UNPACK, just use TRANSPOSE as a demonstrator.
+ !
+ subroutine bar
+ type(container_t), dimension(2,2) :: a1, a2
+ integer :: i, j
+ do i = 1, 2
+ do j = 1, 2
+ allocate (a1(i, j)%entry (2), a2(i, j)%entry (2))
+ a1(i, j)%entry = [i,j]
+ a2(i, j)%entry = [i,j]
+ a1(i,j)%index = j + (i - 1)*2
+ a2(i,j)%index = j + (i - 1)*2
+ end do
+ end do
+ a1 = transpose (a2)
+ do i = 1, 2
+ do j = 1, 2
+ if (a1(i,j)%index .ne. i + (j - 1)*2) call abort
+ if (any (a1(i,j)%entry .ne. [j,i])) call abort
+ end do
+ end do
+ end subroutine
+ end
+
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 155768)
--- gcc/fortran/trans-array.c (working copy)
*************** get_full_array_size (stmtblock_t *block,
*** 5711,5720 ****
}
! /* Allocate dest to the same size as src, and copy src -> dest. */
! tree
! gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank)
{
tree tmp;
tree size;
--- 5711,5722 ----
}
! /* Allocate dest to the same size as src, and copy src -> dest.
! If no_malloc is set, only the copy is done. */
! static tree
! duplicate_allocatable(tree dest, tree src, tree type, int rank,
! bool no_malloc)
{
tree tmp;
tree size;
*************** gfc_duplicate_allocatable(tree dest, tre
*** 5723,5757 ****
tree null_data;
stmtblock_t block;
! /* If the source is null, set the destination to null. */
gfc_init_block (&block);
- gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
- null_data = gfc_finish_block (&block);
! gfc_init_block (&block);
- nelems = get_full_array_size (&block, src, rank);
- size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems,
- fold_convert (gfc_array_index_type,
- TYPE_SIZE_UNIT (gfc_get_element_type (type))));
-
- /* Allocate memory to the destination. */
- tmp = gfc_call_malloc (&block, TREE_TYPE (gfc_conv_descriptor_data_get (src)),
- size);
- gfc_conv_descriptor_data_set (&block, dest, tmp);
-
- /* We know the temporary and the value will be the same length,
- so can use memcpy. */
- tmp = built_in_decls[BUILT_IN_MEMCPY];
- tmp = build_call_expr_loc (input_location,
- tmp, 3, gfc_conv_descriptor_data_get (dest),
- gfc_conv_descriptor_data_get (src), size);
gfc_add_expr_to_block (&block, tmp);
tmp = gfc_finish_block (&block);
/* Null the destination if the source is null; otherwise do
the allocate and copy. */
! null_cond = gfc_conv_descriptor_data_get (src);
null_cond = convert (pvoid_type_node, null_cond);
null_cond = fold_build2 (NE_EXPR, boolean_type_node,
null_cond, null_pointer_node);
--- 5725,5790 ----
tree null_data;
stmtblock_t block;
! /* If the source is null, set the destination to null. Then,
! allocate memory to the destination. */
gfc_init_block (&block);
! if (rank == 0)
! {
! tmp = null_pointer_node;
! tmp = fold_build2 (MODIFY_EXPR, type, dest, tmp);
! gfc_add_expr_to_block (&block, tmp);
! null_data = gfc_finish_block (&block);
!
! gfc_init_block (&block);
! size = TYPE_SIZE_UNIT (type);
! if (!no_malloc)
! {
! tmp = gfc_call_malloc (&block, type, size);
! tmp = fold_build2 (MODIFY_EXPR, void_type_node, dest,
! fold_convert (type, tmp));
! gfc_add_expr_to_block (&block, tmp);
! }
!
! tmp = built_in_decls[BUILT_IN_MEMCPY];
! tmp = build_call_expr_loc (input_location, tmp, 3,
! dest, src, size);
! }
! else
! {
! gfc_conv_descriptor_data_set (&block, dest, null_pointer_node);
! null_data = gfc_finish_block (&block);
!
! gfc_init_block (&block);
! nelems = get_full_array_size (&block, src, rank);
! tmp = fold_convert (gfc_array_index_type,
! TYPE_SIZE_UNIT (gfc_get_element_type (type)));
! size = fold_build2 (MULT_EXPR, gfc_array_index_type, nelems, tmp);
! if (!no_malloc)
! {
! tmp = TREE_TYPE (gfc_conv_descriptor_data_get (src));
! tmp = gfc_call_malloc (&block, tmp, size);
! gfc_conv_descriptor_data_set (&block, dest, tmp);
! }
!
! /* We know the temporary and the value will be the same length,
! so can use memcpy. */
! tmp = built_in_decls[BUILT_IN_MEMCPY];
! tmp = build_call_expr_loc (input_location,
! tmp, 3, gfc_conv_descriptor_data_get (dest),
! gfc_conv_descriptor_data_get (src), size);
! }
gfc_add_expr_to_block (&block, tmp);
tmp = gfc_finish_block (&block);
/* Null the destination if the source is null; otherwise do
the allocate and copy. */
! if (rank == 0)
! null_cond = src;
! else
! null_cond = gfc_conv_descriptor_data_get (src);
!
null_cond = convert (pvoid_type_node, null_cond);
null_cond = fold_build2 (NE_EXPR, boolean_type_node,
null_cond, null_pointer_node);
*************** gfc_duplicate_allocatable(tree dest, tre
*** 5759,5769 ****
}
/* Recursively traverse an object of derived type, generating code to
deallocate, nullify or copy allocatable components. This is the work horse
function for the functions named in this enum. */
! enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP};
static tree
structure_alloc_comps (gfc_symbol * der_type, tree decl,
--- 5792,5821 ----
}
+ /* Allocate dest to the same size as src, and copy data src -> dest. */
+
+ tree
+ gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank)
+ {
+ return duplicate_allocatable(dest, src, type, rank, false);
+ }
+
+
+ /* Copy data src -> dest. */
+
+ tree
+ gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
+ {
+ return duplicate_allocatable(dest, src, type, rank, true);
+ }
+
+
/* Recursively traverse an object of derived type, generating code to
deallocate, nullify or copy allocatable components. This is the work horse
function for the functions named in this enum. */
! enum {DEALLOCATE_ALLOC_COMP = 1, NULLIFY_ALLOC_COMP, COPY_ALLOC_COMP,
! COPY_ONLY_ALLOC_COMP};
static tree
structure_alloc_comps (gfc_symbol * der_type, tree decl,
*************** structure_alloc_comps (gfc_symbol * der_
*** 5786,5792 ****
gfc_init_block (&fnblock);
! if (POINTER_TYPE_P (TREE_TYPE (decl)))
decl = build_fold_indirect_ref_loc (input_location,
decl);
--- 5838,5844 ----
gfc_init_block (&fnblock);
! if (POINTER_TYPE_P (TREE_TYPE (decl)) && rank != 0)
decl = build_fold_indirect_ref_loc (input_location,
decl);
*************** structure_alloc_comps (gfc_symbol * der_
*** 5841,5846 ****
--- 5893,5906 ----
dref = gfc_build_array_ref (tmp, index, NULL);
tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
}
+ else if (purpose == COPY_ONLY_ALLOC_COMP)
+ {
+ tmp = build_fold_indirect_ref_loc (input_location,
+ gfc_conv_array_data (dest));
+ dref = gfc_build_array_ref (tmp, index, NULL);
+ tmp = structure_alloc_comps (der_type, vref, dref, rank,
+ COPY_ALLOC_COMP);
+ }
else
tmp = structure_alloc_comps (der_type, vref, NULL_TREE, rank, purpose);
*************** structure_alloc_comps (gfc_symbol * der_
*** 5978,5984 ****
if (c->attr.allocatable && !cmp_has_alloc_comps)
{
! tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank);
gfc_add_expr_to_block (&fnblock, tmp);
}
--- 6038,6045 ----
if (c->attr.allocatable && !cmp_has_alloc_comps)
{
! rank = c->as ? c->as->rank : 0;
! tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, rank);
gfc_add_expr_to_block (&fnblock, tmp);
}
*************** gfc_deallocate_alloc_comp (gfc_symbol *
*** 6025,6031 ****
/* Recursively traverse an object of derived type, generating code to
! copy its allocatable components. */
tree
gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
--- 6086,6092 ----
/* Recursively traverse an object of derived type, generating code to
! copy it and its allocatable components. */
tree
gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
*************** gfc_copy_alloc_comp (gfc_symbol * der_ty
*** 6034,6039 ****
--- 6095,6110 ----
}
+ /* Recursively traverse an object of derived type, generating code to
+ copy only its allocatable components. */
+
+ tree
+ gfc_copy_only_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank)
+ {
+ return structure_alloc_comps (der_type, decl, dest, rank, COPY_ONLY_ALLOC_COMP);
+ }
+
+
/* NULLIFY an allocatable/pointer array on function entry, free it on exit.
Do likewise, recursively if necessary, with the allocatable components of
derived types. */
Index: gcc/fortran/trans-array.h
===================================================================
*** gcc/fortran/trans-array.h (revision 155768)
--- gcc/fortran/trans-array.h (working copy)
*************** tree gfc_trans_g77_array (gfc_symbol *,
*** 45,51 ****
/* Generate code to deallocate an array, if it is allocated. */
tree gfc_trans_dealloc_allocated (tree);
! tree gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank);
tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int);
--- 45,53 ----
/* Generate code to deallocate an array, if it is allocated. */
tree gfc_trans_dealloc_allocated (tree);
! tree gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank);
!
! tree gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank);
tree gfc_nullify_alloc_comp (gfc_symbol *, tree, int);
*************** tree gfc_deallocate_alloc_comp (gfc_symb
*** 53,58 ****
--- 55,62 ----
tree gfc_copy_alloc_comp (gfc_symbol *, tree, tree, int);
+ tree gfc_copy_only_alloc_comp (gfc_symbol *, tree, tree, int);
+
/* Add initialization for deferred arrays. */
tree gfc_trans_deferred_array (gfc_symbol *, tree);
/* Generate an initializer for a static pointer or allocatable array. */
Index: gcc/fortran/trans-expr.c
===================================================================
*** gcc/fortran/trans-expr.c (revision 155768)
--- gcc/fortran/trans-expr.c (working copy)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 2757,2762 ****
--- 2757,2763 ----
tree var;
tree len;
tree stringargs;
+ tree result = NULL;
gfc_formal_arglist *formal;
int has_alternate_specifier = 0;
bool need_interface_mapping;
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3288,3293 ****
--- 3289,3296 ----
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
+ result = build_fold_indirect_ref_loc (input_location,
+ se->expr);
retargs = gfc_chainon_list (retargs, se->expr);
}
else if (comp && comp->attr.dimension)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3310,3317 ****
callee_alloc, &se->ss->expr->where);
/* Pass the temporary as the first argument. */
! tmp = info->descriptor;
! tmp = gfc_build_addr_expr (NULL_TREE, tmp);
retargs = gfc_chainon_list (retargs, tmp);
}
else if (!comp && sym->result->attr.dimension)
--- 3313,3320 ----
callee_alloc, &se->ss->expr->where);
/* Pass the temporary as the first argument. */
! result = info->descriptor;
! tmp = gfc_build_addr_expr (NULL_TREE, result);
retargs = gfc_chainon_list (retargs, tmp);
}
else if (!comp && sym->result->attr.dimension)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3334,3341 ****
callee_alloc, &se->ss->expr->where);
/* Pass the temporary as the first argument. */
! tmp = info->descriptor;
! tmp = gfc_build_addr_expr (NULL_TREE, tmp);
retargs = gfc_chainon_list (retargs, tmp);
}
else if (ts.type == BT_CHARACTER)
--- 3337,3344 ----
callee_alloc, &se->ss->expr->where);
/* Pass the temporary as the first argument. */
! result = info->descriptor;
! tmp = gfc_build_addr_expr (NULL_TREE, result);
retargs = gfc_chainon_list (retargs, tmp);
}
else if (ts.type == BT_CHARACTER)
*************** gfc_conv_procedure_call (gfc_se * se, gf
*** 3487,3493 ****
/* Follow the function call with the argument post block. */
if (byref)
! gfc_add_block_to_block (&se->pre, &post);
else
gfc_add_block_to_block (&se->post, &post);
--- 3490,3525 ----
/* Follow the function call with the argument post block. */
if (byref)
! {
! gfc_add_block_to_block (&se->pre, &post);
!
! /* Transformational functions of derived types with allocatable
! components must have the result allocatable components copied. */
! arg = expr->value.function.actual;
! if (result && arg && expr->rank
! && expr->value.function.isym
! && expr->value.function.isym->transformational
! && arg->expr->ts.type == BT_DERIVED
! && arg->expr->ts.u.derived->attr.alloc_comp)
! {
! tree tmp2;
! /* Copy the allocatable components. We have to use a
! temporary here to prevent source allocatable components
! from being corrupted. */
! tmp2 = gfc_evaluate_now (result, &se->pre);
! tmp = gfc_copy_alloc_comp (arg->expr->ts.u.derived,
! result, tmp2, expr->rank);
! gfc_add_expr_to_block (&se->pre, tmp);
! tmp = gfc_copy_allocatable_data (result, tmp2, TREE_TYPE(tmp2),
! expr->rank);
! gfc_add_expr_to_block (&se->pre, tmp);
!
! /* Finally free the temporary's data field. */
! tmp = gfc_conv_descriptor_data_get (tmp2);
! tmp = gfc_deallocate_with_status (tmp, NULL_TREE, true, NULL);
! gfc_add_expr_to_block (&se->pre, tmp);
! }
! }
else
gfc_add_block_to_block (&se->post, &post);
*************** gfc_trans_arrayfunc_assign (gfc_expr * e
*** 4906,4911 ****
--- 4938,4952 ----
gfc_conv_array_parameter (&se, expr1, ss, 0, NULL, NULL, NULL);
+ if (expr1->ts.type == BT_DERIVED
+ && expr1->ts.u.derived->attr.alloc_comp)
+ {
+ tree tmp;
+ tmp = gfc_deallocate_alloc_comp (expr1->ts.u.derived, se.expr,
+ expr1->rank);
+ gfc_add_expr_to_block (&se.pre, tmp);
+ }
+
se.direct_byref = 1;
se.ss = gfc_walk_expr (expr2);
gcc_assert (se.ss != gfc_ss_terminator);