https://gcc.gnu.org/g:beff10e1d5db3cea664553d8eaac2b807397f1e5
commit beff10e1d5db3cea664553d8eaac2b807397f1e5 Author: Mikael Morin <[email protected]> Date: Mon Jun 29 21:33:01 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 a dummy array matches this case, and a dummy array can be associated with a transposed array. 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 below). 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 only copies the lbound and ubound from the original descriptor, and using matching dimensions. And 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 ebd04c53b9d2..181f4c68562a 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -9766,14 +9766,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"); @@ -9838,19 +9834,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 @@ -9866,7 +9898,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..75dd927537ae --- /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 a contiguous assumed-shape +! dummy +! +! 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
