https://gcc.gnu.org/g:6658c2347d4a88d82e80f44a450b14dc7287bcef
commit r17-2111-g6658c2347d4a88d82e80f44a450b14dc7287bcef Author: Mikael Morin <[email protected]> Date: Fri Jul 3 11:16:04 2026 +0200 fortran: Don't reuse original descriptors for packed arrays [PR125998] Don't try to reuse the original descriptor when creating a descriptor for packed data in gfc_conv_array_parameter. For a non-transposed array (anything but TRANSPOSE(VAR)) the original descriptor was reused, and only the data was reset to the result of packing. This is wrong because the original descriptor can be non-contiguous, it can't be correct as the descriptor of packed data. In the testcase, a dummy array associated with a transposed array actual argument matches this case. Reusing the descriptor in that case would cause the packed data to be used transposed, that is not in the normal array element order. This change removes this case to always fallback to what was previously the transposed case (see next). For the transposed case (TRANSPOSE(VAR)), the full dimensions of the original untransposed descriptor were reused (in other words, the dimensions of VAR). This is wrong because packing doesn't change the shape, so the packed array should have the same bounds as the bounds of TRANSPOSE(VAR), not the same bounds as VAR. Reusing the strides of an unpacked array for a packed array doesn't seem right either. This change uses matching dimensions when copying from the original descriptor, and only copies the lbound and ubound. The strides are recalculated. And then the offset is recalculated as well (even though I couldn't find a testcase where it made a difference). PR fortran/97592 PR fortran/125998 gcc/fortran/ChangeLog: * trans-array.cc (gfc_conv_array_parameter): Always create a new descriptor. Copy lbound and ubound from the original descriptor using matching dimension indexes. Recalculate stride and offset. gcc/testsuite/ChangeLog: * gfortran.dg/contiguous_17.f90: New test. Diff: --- gcc/fortran/trans-array.cc | 65 +++++--- gcc/testsuite/gfortran.dg/contiguous_17.f90 | 229 ++++++++++++++++++++++++++++ 2 files changed, 277 insertions(+), 17 deletions(-) diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index f2b03b42efbb..d1153f5565cf 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -9261,14 +9261,10 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77, { tmp = build_fold_indirect_ref_loc (input_location, desc); - gfc_ss * ss = gfc_walk_expr (expr); - if (!transposed_dims (ss) && expr->rank != -1) - { - if (!ctree) - gfc_conv_descriptor_data_set (&se->pre, tmp, ptr); - } - else if (!ctree) + if (!ctree) { + /* The original descriptor may have transposed dims so we + can't reuse it directly; we have to create a new one. */ tree old_field, new_field; tree old_desc = tmp; tree new_desc = gfc_create_var (TREE_TYPE (old_desc), "arg_desc"); @@ -9333,19 +9329,55 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77, } else { - /* The original descriptor has transposed dims so we can't - reuse it directly; we have to create a new one. */ - old_field = gfc_conv_descriptor_offset_get (old_desc); - gfc_conv_descriptor_offset_set (&se->pre, new_desc, old_field); + tree offset = gfc_index_zero_node; + + tree stride = gfc_index_one_node; for (int i = 0; i < expr->rank; i++) { - old_field = gfc_conv_descriptor_dimension (old_desc, - gfc_rank_cst[get_array_ref_dim_for_loop_dim (ss, i)]); - new_field = gfc_conv_descriptor_dimension (new_desc, - gfc_rank_cst[i]); - gfc_add_modify (&se->pre, new_field, old_field); + tree dim = gfc_rank_cst[i]; + + tree lbound = gfc_conv_descriptor_lbound_get (old_desc, + dim); + lbound = gfc_evaluate_now (lbound, &se->pre); + gfc_conv_descriptor_lbound_set (&se->pre, new_desc, dim, + lbound); + + tree ubound = gfc_conv_descriptor_ubound_get (old_desc, + dim); + ubound = gfc_evaluate_now (ubound, &se->pre); + gfc_conv_descriptor_ubound_set (&se->pre, new_desc, dim, + ubound); + + gfc_conv_descriptor_stride_set (&se->pre, new_desc, dim, + stride); + + tree tmp = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + stride, lbound); + offset = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + offset, tmp); + offset = gfc_evaluate_now (offset, &se->pre); + + /* Now calculate the stride for next dimension, unless the + current dimension is the last one. */ + if (i == expr->rank - 1) + break; + + tmp = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + lbound, gfc_index_one_node); + tree extent = fold_build2_loc (input_location, MINUS_EXPR, + gfc_array_index_type, + ubound, tmp); + stride = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + stride, extent); + stride = gfc_evaluate_now (stride, &se->pre); } + + gfc_conv_descriptor_offset_set (&se->pre, new_desc, offset); } if (flag_coarray == GFC_FCOARRAY_LIB @@ -9361,7 +9393,6 @@ gfc_conv_array_parameter (gfc_se *se, gfc_expr *expr, bool g77, gfc_conv_descriptor_data_set (&se->pre, new_desc, ptr); se->expr = gfc_build_addr_expr (NULL_TREE, new_desc); } - gfc_free_ss (ss); } if (gfc_option.rtcheck & GFC_RTCHECK_ARRAY_TEMPS) diff --git a/gcc/testsuite/gfortran.dg/contiguous_17.f90 b/gcc/testsuite/gfortran.dg/contiguous_17.f90 new file mode 100644 index 000000000000..0fd27b1d41e0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/contiguous_17.f90 @@ -0,0 +1,229 @@ +! { dg-do run } +! +! PR fortran/125998 +! Check the correct passing of a transposed array to an assumed-shape dummy +! having the contiguous and target attributes. +! +! Original testcase from Federico Perini <[email protected]> + +subroutine original + real(8) :: a(3,4) + integer :: dims(2) + character(48) :: iomsg + call show(transpose(a),dims) + if (any(dims/=shape(transpose(a)))) then + write(iomsg,1) 'invalid a^T dims',dims, & + ' should be',shape(transpose(a)) + error stop iomsg + endif + 1 format(*(a,' [',i0,',',i0,']')) + +contains + + subroutine show(x,dims) + ! "3 4" with `contiguous` (BUG); "4 3" without + real(8), intent(in), target, contiguous :: x(:,:) + integer, intent(out) :: dims(2) + dims = [size(x,1),size(x,2)] + end + +end + +module m + implicit none + private + public :: check_all + +contains + + subroutine abort_different(lx,x,ly,y,code) + character(*), intent(in) :: lx, ly + integer, intent(in) :: x(..), y(..), code + write(6,'(a," /= ",a)') lx, ly + select rank(x) + rank(1) + write(6,3) lx + write(6,*) x + rank(2) + write(6,3) lx + write(6,*) x + rank default + end select + select rank(y) + rank(1) + write(6,3) ly + write(6,*) y + rank(2) + write(6,3) ly + write(6,*) y + rank default + end select + error stop code + 3 format(a,":") + end subroutine + + subroutine check_target(x,expected,num_error) + integer, intent(in), target, contiguous :: x(:,:) + integer, intent(in) :: num_error, expected(:,:) + if (any(shape(x) /= shape(expected))) then + call abort_different( & + "shape(x)",shape(x), & + "shape(expected)",shape(expected), & + num_error*10+1 & + ) + end if + if (any(x /= expected)) then + call abort_different("x",x,"expected",expected,num_error*10+2) + end if + if (x(2,2) /= expected(2,2)) then + call abort_different( & + "x(2,2)",x(2,2), & + "expected(2,2)",expected(2,2), & + num_error*10+3 & + ) + end if + end + + subroutine check_non_target(x,expected,num_error) + integer, intent(in), contiguous :: x(:,:) + integer, intent(in) :: num_error, expected(:,:) + if (any(shape(x) /= shape(expected))) then + call abort_different( & + "shape(x)",shape(x), & + "shape(expected)",shape(expected), & + num_error*10+1 & + ) + end if + if (any(x /= expected)) then + call abort_different("x",x,"expected",expected,num_error*10+2) + end if + if (x(2,2) /= expected(2,2)) then + call abort_different( & + "x(2,2)",x(2,2), & + "expected(2,2)",expected(2,2), & + num_error*10+3 & + ) + end if + end + + subroutine wrapper_target(x,expected,num_error) + integer, intent(in), target :: x(:,:) + integer, intent(in) :: expected(:,:) + integer, intent(in) :: num_error + call check_target(x,expected,num_error) + end subroutine + + subroutine wrapper_non_target(x,expected,num_error) + integer, intent(in) :: x(:,:), expected(:,:) + integer, intent(in) :: num_error + call check_non_target(x,expected,num_error) + end subroutine + + subroutine wrapper_transpose_target(x,expected,num_error) + integer, intent(in), target :: x(:,:) + integer, intent(in) :: expected(:,:) + integer, intent(in) :: num_error + call check_target(transpose(x),expected,num_error) + end subroutine + + subroutine wrapper_transpose_non_target(x,expected,num_error) + integer, intent(in) :: x(:,:), expected(:,:) + integer, intent(in) :: num_error + call check_non_target(transpose(x),expected,num_error) + end subroutine + + subroutine check_all + integer :: a(3,4) + + a = reshape([0,1,1,2,3,5,8,13,21,34,55,89],shape(a)) + call check_target( & + transpose(a), & + reshape([0,2,8,34,1,3,13,55,1,5,21,89],[4,3]), & + 1 & + ) + + a = reshape([0,1,1,2,3,5,8,13,21,34,55,89],shape(a)) + call check_non_target( & + transpose(a), & + reshape([0,2,8,34,1,3,13,55,1,5,21,89],[4,3]), & + 2 & + ) + + a = reshape([0,1,1,2,3,5,8,13,21,34,55,89],shape(a)) + call wrapper_target( & + transpose(a), & + reshape([0,2,8,34,1,3,13,55,1,5,21,89],[4,3]), & + 3 & + ) + + a = reshape([0,1,1,2,3,5,8,13,21,34,55,89],shape(a)) + call wrapper_non_target( & + transpose(a), & + reshape([0,2,8,34,1,3,13,55,1,5,21,89],[4,3]), & + 4 & + ) + + a = reshape([0,1,1,2,3,5,8,13,21,34,55,89],shape(a)) + call wrapper_transpose_target( & + a, & + reshape([0,2,8,34,1,3,13,55,1,5,21,89],[4,3]), & + 5 & + ) + + a = reshape([0,1,1,2,3,5,8,13,21,34,55,89],shape(a)) + call wrapper_transpose_non_target( & + a, & + reshape([0,2,8,34,1,3,13,55,1,5,21,89],[4,3]), & + 6 & + ) + + a = reshape([0,1,1,2,3,5,8,13,21,34,55,89],shape(a)) + call wrapper_transpose_target( & + transpose(a), & + reshape([0,1,1,2,3,5,8,13,21,34,55,89],[3,4]), & + 7 & + ) + + a = reshape([0,1,1,2,3,5,8,13,21,34,55,89],shape(a)) + call wrapper_transpose_non_target( & + transpose(a), & + reshape([0,1,1,2,3,5,8,13,21,34,55,89],[3,4]), & + 8 & + ) + + a = reshape([0,1,1,2,3,5,8,13,21,34,55,89],shape(a)) + call check_target( & + a(::2,::2), & + reshape([0,1,8,21],[2,2]), & + 9 & + ) + + a = reshape([0,1,1,2,3,5,8,13,21,34,55,89],shape(a)) + call check_non_target( & + a(::2,::2), & + reshape([0,1,8,21],[2,2]), & + 10 & + ) + + a = reshape([0,1,1,2,3,5,8,13,21,34,55,89],shape(a)) + call wrapper_target( & + a(::2,::2), & + reshape([0,1,8,21],[2,2]), & + 11 & + ) + + a = reshape([0,1,1,2,3,5,8,13,21,34,55,89],shape(a)) + call wrapper_non_target( & + a(::2,::2), & + reshape([0,1,8,21],[2,2]), & + 12 & + ) + + end subroutine + +end module + +use m +call original +call check_all +end
