From 12df8d0150a2f18d7e86a8b0a94cfc4201795c18 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Mon, 18 Apr 2011 05:07:38 +0000 Subject: [PATCH] re PR fortran/48462 (realloc on assignment: matmul Segmentation Fault with Allocatable Array) 2011-04-18 Paul Thomas PR fortran/48462 * trans-expr.c (fcncall_realloc_result): Renamed version of realloc_lhs_bounds_for_intrinsic_call that does not touch the descriptor bounds anymore but makes a temporary descriptor to hold the result. (gfc_trans_arrayfunc_assign): Modify the reference to above renamed function. 2011-04-18 Paul Thomas PR fortran/48462 * gfortran.dg/realloc_on_assign_7.f03: New test. From-SVN: r172636 --- gcc/fortran/ChangeLog | 10 +++ gcc/fortran/trans-expr.c | 63 +++++++------------ gcc/testsuite/ChangeLog | 5 ++ .../gfortran.dg/realloc_on_assign_7.f03 | 51 +++++++++++++++ 4 files changed, 89 insertions(+), 40 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index cdb53e7952d..97f34107888 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2011-04-18 Paul Thomas + + PR fortran/48462 + * trans-expr.c (fcncall_realloc_result): Renamed version of + realloc_lhs_bounds_for_intrinsic_call that does not touch the + descriptor bounds anymore but makes a temporary descriptor to + hold the result. + (gfc_trans_arrayfunc_assign): Modify the reference to above + renamed function. + 2011-05-17 Tobias Burnus PR fortran/48624 diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index dc9168a0957..92a0fe9744e 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -5528,55 +5528,38 @@ realloc_lhs_loop_for_fcn_call (gfc_se *se, locus *where, gfc_ss **ss, } +/* For Assignment to a reallocatable lhs from intrinsic functions, + replace the se.expr (ie. the result) with a temporary descriptor. + Null the data field so that the library allocates space for the + result. Free the data of the original descriptor after the function, + in case it appears in an argument expression and transfer the + result to the original descriptor. */ + static void -realloc_lhs_bounds_for_intrinsic_call (gfc_se *se, int rank) +fcncall_realloc_result (gfc_se *se) { tree desc; + tree res_desc; tree tmp; - tree offset; - int n; - /* Use the allocation done by the library. */ + /* Use the allocation done by the library. Substitute the lhs + descriptor with a copy, whose data field is nulled.*/ desc = build_fold_indirect_ref_loc (input_location, se->expr); + res_desc = gfc_evaluate_now (desc, &se->pre); + gfc_conv_descriptor_data_set (&se->pre, res_desc, null_pointer_node); + se->expr = gfc_build_addr_expr (TREE_TYPE (se->expr), res_desc); + + /* Free the lhs after the function call and copy the result data to + it. */ tmp = gfc_conv_descriptor_data_get (desc); tmp = gfc_call_free (fold_convert (pvoid_type_node, tmp)); - gfc_add_expr_to_block (&se->pre, tmp); - gfc_conv_descriptor_data_set (&se->pre, desc, null_pointer_node); + gfc_add_expr_to_block (&se->post, tmp); + tmp = gfc_conv_descriptor_data_get (res_desc); + gfc_conv_descriptor_data_set (&se->post, desc, tmp); + /* Unallocated, the descriptor does not have a dtype. */ tmp = gfc_conv_descriptor_dtype (desc); - gfc_add_modify (&se->pre, tmp, gfc_get_dtype (TREE_TYPE (desc))); - - offset = gfc_index_zero_node; - tmp = gfc_index_one_node; - /* Now reset the bounds from zero based to unity based. */ - for (n = 0 ; n < rank; n++) - { - /* Accumulate the offset. */ - offset = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - offset, tmp); - /* Now do the bounds. */ - gfc_conv_descriptor_offset_set (&se->post, desc, tmp); - tmp = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - tmp, gfc_index_one_node); - gfc_conv_descriptor_lbound_set (&se->post, desc, - gfc_rank_cst[n], - gfc_index_one_node); - gfc_conv_descriptor_ubound_set (&se->post, desc, - gfc_rank_cst[n], tmp); - - /* The extent for the next contribution to offset. */ - tmp = fold_build2_loc (input_location, MINUS_EXPR, - gfc_array_index_type, - gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[n]), - gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[n])); - tmp = fold_build2_loc (input_location, PLUS_EXPR, - gfc_array_index_type, - tmp, gfc_index_one_node); - } - gfc_conv_descriptor_offset_set (&se->post, desc, offset); + gfc_add_modify (&se->post, tmp, gfc_get_dtype (TREE_TYPE (desc))); } @@ -5646,7 +5629,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2) ss->is_alloc_lhs = 1; } else - realloc_lhs_bounds_for_intrinsic_call (&se, expr1->rank); + fcncall_realloc_result (&se); } gfc_conv_function_expr (&se, expr2); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 889995dd8d8..4d3019e117f 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2011-04-18 Paul Thomas + + PR fortran/48462 + * gfortran.dg/realloc_on_assign_7.f03: New test. + 2011-04-17 Jerry DeLisle PR libgfortran/48602 diff --git a/gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03 b/gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03 new file mode 100644 index 00000000000..8de46c0b8e0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/realloc_on_assign_7.f03 @@ -0,0 +1,51 @@ +! { dg-do run } +! Check the fix for PR48462 in which the assignments involving matmul +! seg faulted because a was automatically freed before the assignment. +! +! Contributed by John Nedney +! +program main + implicit none + integer, parameter :: dp = kind(0.0d0) + real(kind=dp), allocatable :: delta(:,:) + + call foo + call bar +contains +! +! Original reduced version from comment #2 + subroutine foo + implicit none + real(kind=dp), allocatable :: a(:,:) + real(kind=dp), allocatable :: b(:,:) + + allocate(a(3,3)) + allocate(b(3,3)) + allocate(delta(3,3)) + + b = reshape ([1d0, 0d0, 0d0, 0d0, 1d0, 0d0, 0d0, 0d0, 1d0], [3,3]) + a = reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3]) + + a = matmul( matmul( a, b ), b ) + delta = (a - reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3]))**2 + if (any (delta > 1d-12)) call abort + if (any (lbound (a) .ne. [1, 1])) call abort + end subroutine +! +! Check that all is well when the shape of 'a' changes. + subroutine bar + implicit none + real(kind=dp), allocatable :: a(:,:) + real(kind=dp), allocatable :: b(:,:) + + b = reshape ([1d0, 1d0, 1d0], [3,1]) + a = reshape ([1d0, 2d0, 3d0, 4d0, 5d0, 6d0, 7d0, 8d0, 9d0], [3,3]) + + a = matmul( a, matmul( a, b ) ) + + delta = (a - reshape ([198d0, 243d0, 288d0], [3,1]))**2 + if (any (delta > 1d-12)) call abort + if (any (lbound (a) .ne. [1, 1])) call abort + end subroutine +end program main + -- 2.30.2