From 64a8f98f2b7d200f6b8ddb5970d6f72a45fd4bab Mon Sep 17 00:00:00 2001 From: pault Date: Thu, 14 Jan 2010 06:17:38 +0000 Subject: [PATCH 1/1] 2010-01-14 Paul Thomas 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-14 Paul Thomas PR fortran/41478 * gfortran.dg/alloc_comp_scalar_1.f90: New test. * gfortran.dg/alloc_comp_transformational_1.f90: New test. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@155877 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/fortran/ChangeLog | 25 ++++ gcc/fortran/trans-array.c | 127 ++++++++++++++++----- gcc/fortran/trans-array.h | 6 +- gcc/fortran/trans-expr.c | 51 ++++++++- gcc/testsuite/ChangeLog | 6 + gcc/testsuite/gfortran.dg/alloc_comp_scalar_1.f90 | 17 +++ .../gfortran.dg/alloc_comp_transformational_1.f90 | 80 +++++++++++++ 7 files changed, 278 insertions(+), 34 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/alloc_comp_scalar_1.f90 create mode 100644 gcc/testsuite/gfortran.dg/alloc_comp_transformational_1.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index be65b9ab58e..204d2420221 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,5 +1,30 @@ 2010-01-14 Paul Thomas + 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-14 Paul Thomas + PR fortran/42481 * module.c (load_generic_interfaces): If a procedure that is use associated but not generic is given an interface that diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 063b26297a7..d512da4db6b 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -5711,10 +5711,12 @@ get_full_array_size (stmtblock_t *block, tree decl, int rank) } -/* Allocate dest to the same size as src, and copy src -> dest. */ +/* Allocate dest to the same size as src, and copy src -> dest. + If no_malloc is set, only the copy is done. */ -tree -gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank) +static tree +duplicate_allocatable(tree dest, tree src, tree type, int rank, + bool no_malloc) { tree tmp; tree size; @@ -5723,35 +5725,66 @@ gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank) tree null_data; stmtblock_t block; - /* If the source is null, set the destination to null. */ + /* If the source is null, set the destination to null. Then, + allocate memory to the destination. */ gfc_init_block (&block); - gfc_conv_descriptor_data_set (&block, dest, null_pointer_node); - null_data = gfc_finish_block (&block); - 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); + } - 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); + 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); @@ -5759,11 +5792,30 @@ gfc_duplicate_allocatable(tree dest, tree src, tree type, int rank) } +/* 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}; +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, @@ -5786,7 +5838,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_init_block (&fnblock); - if (POINTER_TYPE_P (TREE_TYPE (decl))) + if (POINTER_TYPE_P (TREE_TYPE (decl)) && rank != 0) decl = build_fold_indirect_ref_loc (input_location, decl); @@ -5841,6 +5893,14 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, 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); @@ -5978,7 +6038,8 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, if (c->attr.allocatable && !cmp_has_alloc_comps) { - tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, c->as->rank); + rank = c->as ? c->as->rank : 0; + tmp = gfc_duplicate_allocatable(dcmp, comp, ctype, rank); gfc_add_expr_to_block (&fnblock, tmp); } @@ -6025,7 +6086,7 @@ gfc_deallocate_alloc_comp (gfc_symbol * der_type, tree decl, int rank) /* Recursively traverse an object of derived type, generating code to - copy its allocatable components. */ + copy it and its allocatable components. */ tree gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank) @@ -6034,6 +6095,16 @@ gfc_copy_alloc_comp (gfc_symbol * der_type, tree decl, tree dest, int rank) } +/* 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. */ diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 175b3c60ff5..6807fcbe612 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -45,7 +45,9 @@ tree gfc_trans_g77_array (gfc_symbol *, tree); /* 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_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); @@ -53,6 +55,8 @@ tree gfc_deallocate_alloc_comp (gfc_symbol *, tree, int); 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. */ diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 5ce5dcec4c5..bb69d454e92 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2757,6 +2757,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, tree var; tree len; tree stringargs; + tree result = NULL; gfc_formal_arglist *formal; int has_alternate_specifier = 0; bool need_interface_mapping; @@ -3288,6 +3289,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, 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) @@ -3310,8 +3313,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, callee_alloc, &se->ss->expr->where); /* Pass the temporary as the first argument. */ - tmp = info->descriptor; - tmp = gfc_build_addr_expr (NULL_TREE, tmp); + result = info->descriptor; + tmp = gfc_build_addr_expr (NULL_TREE, result); retargs = gfc_chainon_list (retargs, tmp); } else if (!comp && sym->result->attr.dimension) @@ -3334,8 +3337,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, callee_alloc, &se->ss->expr->where); /* Pass the temporary as the first argument. */ - tmp = info->descriptor; - tmp = gfc_build_addr_expr (NULL_TREE, tmp); + result = info->descriptor; + tmp = gfc_build_addr_expr (NULL_TREE, result); retargs = gfc_chainon_list (retargs, tmp); } else if (ts.type == BT_CHARACTER) @@ -3487,7 +3490,36 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, /* Follow the function call with the argument post block. */ if (byref) - gfc_add_block_to_block (&se->pre, &post); + { + 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); @@ -4906,6 +4938,15 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) 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); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 2195d2e35ea..ffe006a646e 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,5 +1,11 @@ 2010-01-14 Paul Thomas + PR fortran/41478 + * gfortran.dg/alloc_comp_scalar_1.f90: New test. + * gfortran.dg/alloc_comp_transformational_1.f90: New test. + +2010-01-14 Paul Thomas + PR fortran/42481 * gfortran.dg/generic_19.f90 : New test. diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_scalar_1.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_scalar_1.f90 new file mode 100644 index 00000000000..82cf71fc4fe --- /dev/null +++ b/gcc/testsuite/gfortran.dg/alloc_comp_scalar_1.f90 @@ -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 +! +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 diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_transformational_1.f90 b/gcc/testsuite/gfortran.dg/alloc_comp_transformational_1.f90 new file mode 100644 index 00000000000..13ee8a88bde --- /dev/null +++ b/gcc/testsuite/gfortran.dg/alloc_comp_transformational_1.f90 @@ -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 +! + 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 + -- 2.11.0