[Fortran, Patch, PR 96992] Fix Class arrays of different ranks are rejected as storage association argument

[Fortran, Patch, PR 96992] Fix Class arrays of different ranks are rejected as storage association argument

[Andre Vehreschild]

[-- Attachment #1: Type: text/plain, Size: 661 bytes --]

Hi all,

I somehow got assigned to this PR so I fixed it. GFortran was ICEing because of
the ASSUME_RANK in a derived to class conversion. After fixing this, storage
association was producing segfaults. The "shape conversion" of the class array
as dummy argument was not initializing the dim 0 stride and with that grabbing
into the memory somewhere. This is now fixed and

regtests fine on x86_64 Fedora 39. Ok for mainline?

I assume this patch could be fixing some other PRs with class array's parameter
passing, too. If that sounds familiar, feel free to point me to them.

Regards,
	Andre
--
Andre Vehreschild * Email: vehre ad gmx dot de

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: pr96992_1.patch --]
[-- Type: text/x-patch, Size: 4701 bytes --]

From 86ac3179e1314ca1c41f52025c5a156ad7346dc1 Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <vehre@gcc.gnu.org>
Date: Fri, 14 Jun 2024 16:54:37 +0200
Subject: [PATCH] Fortran: [PR96992] Fix rejecting class arrays of different
 ranks as storage association argument.

Removing the assert in trans-expr, lead to initial strides not set
which is not fixed.

	PR fortran/96992

gcc/fortran/ChangeLog:

	* trans-array.cc (gfc_trans_array_bounds): Set a starting
	stride, when descriptor expects a variable for the stride.
	(gfc_trans_dummy_array_bias): Allow storage association for
	dummy class arrays, when they are not elemental.
	* trans-expr.cc (gfc_conv_derived_to_class): Remove assert to
	allow converting derived to class type arrays with assumend
	rank.

gcc/testsuite/ChangeLog:

	* gfortran.dg/pr96992.f90: New test.
---
 gcc/fortran/trans-array.cc            |  7 ++-
 gcc/fortran/trans-expr.cc             |  2 -
 gcc/testsuite/gfortran.dg/pr96992.f90 | 61 +++++++++++++++++++++++++++
 3 files changed, 67 insertions(+), 3 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/pr96992.f90

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index b3088a892c8..9fa8bad2f35 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -6798,6 +6798,9 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,

   size = gfc_index_one_node;
   offset = gfc_index_zero_node;
+  stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
+  if (stride && VAR_P (stride))
+    gfc_add_modify (pblock, stride, gfc_index_one_node);
   for (dim = 0; dim < as->rank; dim++)
     {
       /* Evaluate non-constant array bound expressions.
@@ -7134,7 +7137,9 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
       || (is_classarray && CLASS_DATA (sym)->attr.allocatable))
     return;

-  if (!is_classarray && sym->attr.dummy && gfc_is_nodesc_array (sym))
+  if ((!is_classarray
+       || (is_classarray && CLASS_DATA (sym)->as->type == AS_EXPLICIT))
+      && sym->attr.dummy && !sym->attr.elemental && gfc_is_nodesc_array (sym))
     {
       gfc_trans_g77_array (sym, block);
       return;
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 0796fb75505..4bb62cfb1ad 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -903,8 +903,6 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,

 	  if (e->rank != class_ts.u.derived->components->as->rank)
 	    {
-	      gcc_assert (class_ts.u.derived->components->as->type
-			  == AS_ASSUMED_RANK);
 	      if (derived_array
 		  && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr)))
 		{
diff --git a/gcc/testsuite/gfortran.dg/pr96992.f90 b/gcc/testsuite/gfortran.dg/pr96992.f90
new file mode 100644
index 00000000000..c56ed80f394
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr96992.f90
@@ -0,0 +1,61 @@
+! { dg-do run }
+
+! PR fortran/96992
+
+! Contributed by Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+! From the standard:
+! An actual argument that represents an element sequence and
+! corresponds to a dummy argument that is an array is sequence
+! associated with the dummy argument. The rank and shape of the
+! actual argument need not agree with the rank and shape of the
+! dummy argument, but the number of elements in the dummy argument
+! shall not exceed the number of elements in the element sequence
+! of the actual argument. If the dummy argument is assumed-size,
+! the number of elements in the dummy argument is exactly
+! the number of elements in the element sequence.
+
+! Check that walking the sequence starts with an initialized stride
+! for dim == 0.
+
+module foo_mod
+  implicit none
+  type foo
+     integer :: i
+  end type foo
+contains
+  subroutine d1(x,n)
+    integer, intent(in) :: n
+    integer :: i
+    class (foo), intent(out), dimension(n) :: x
+    select type(x)
+    class is(foo)
+       x(:)%i = (/ (42 + i, i = 1, n ) /)
+    class default
+       stop 1
+    end select
+  end subroutine d1
+  subroutine d2(x,n)
+    integer, intent(in) :: n
+    integer :: i
+    class (foo), intent(in), dimension(n,n,n) :: x
+    select type (x)
+    class is (foo)
+       print *,x%i
+       if ( any( x%i /= reshape((/ (42 + i, i = 1, n ** 3 ) /), [n, n, n] ))) stop 2
+    class default
+       stop 3
+    end select
+  end subroutine d2
+end module foo_mod
+program main
+  use foo_mod
+  implicit none
+  type (foo), dimension(:), allocatable :: f
+  integer :: n
+  n = 3
+  allocate (f(n*n*n))
+  call d1(f,n*n*n)
+  call d2(f,n)
+end program main
+
--
2.45.1

Re: [Fortran, Patch, PR 96992] Fix Class arrays of different ranks are rejected as storage association argument

[Harald Anlauf]

Hi Andre,

Am 14.06.24 um 17:05 schrieb Andre Vehreschild:
> Hi all,
>
> I somehow got assigned to this PR so I fixed it. GFortran was ICEing because of
> the ASSUME_RANK in a derived to class conversion. After fixing this, storage
> association was producing segfaults. The "shape conversion" of the class array
> as dummy argument was not initializing the dim 0 stride and with that grabbing
> into the memory somewhere. This is now fixed and
>
> regtests fine on x86_64 Fedora 39. Ok for mainline?

the patch fixes the testcase in your submission, but not the following
slight variation of the main program:

module foo_mod
   implicit none
   type foo
      integer :: i
   end type foo
contains
   subroutine d1(x,n)
     integer, intent(in) :: n
     integer :: i
     class (foo), intent(out) :: x(n)
     select type(x)
     class is(foo)
        x(:)%i = (/ (42 + i, i = 1, n ) /)
     class default
        stop 1
     end select
   end subroutine d1
   subroutine d2(x,n)
     integer, intent(in) :: n
     integer :: i
     class (foo), intent(in) :: x(n,n,n)
     select type (x)
     class is (foo)
        print *,x%i
        if ( any( x%i /= reshape((/ (42 + i, i = 1, n ** 3 ) /), [n, n,
n] ))) stop 2
     class default
        stop 3
     end select
   end subroutine d2
end module foo_mod
program main
   use foo_mod
   implicit none
   type (foo), dimension(:), allocatable :: f
   integer :: n
   n = 2
   allocate (f(n*n*n))
   ! Original testcase:
   call d1(f,n*n*n)
   call d2(f,n)                  ! OK
   call d1(f(1:n*n*n),n*n*n)
   print *, "After call d1(f(1:n*n*n:1),n*n*n):"
   print *, f%i
   call d2(f(1:n*n*n),n)         ! OK
   ! Using stride -1:
   call d1(f(n*n*n:1:-1),n*n*n)
   print *, "After call d1(f(n*n*n:1:-1),n*n*n):"
   print *, f%i
   call d2(f(n*n*n:1:-1),n)      ! not OK
   deallocate (f)
end program main

While this runs fine with the latest Intel compiler, gfortran including
your patch prints:

           43          44          45          46          47
48          49          50
  After call d1(f(1:n*n*n:1),n*n*n):
           43          44          45          46          47
48          49          50
           43          44          45          46          47
48          49          50
  After call d1(f(n*n*n:1:-1),n*n*n):
           50          49          48          47          46
45          44          43
           43           0           0          49           0
34244976           0    34238480
STOP 2

So while the negative stride (-1) in the call to d1 appears to
work as it should, it does not work properly for the call to d2.
The first array element is fine in d2, but anything else isn't.

Do you see what goes wrong here?

(This may be a more general, pre-existing issue in a different place.)

Thanks,
Harald

P.S.: regarding your commit message, I think the reference to the pr
in brackets should be moved to the end of the summary line, i.e. for

Fortran: [PR96992] Fix rejecting class arrays of different ranks as
storage association argument.

the "[PR96992" should be moved.  Makes it also easier to read.

> I assume this patch could be fixing some other PRs with class array's parameter
> passing, too. If that sounds familiar, feel free to point me to them.
>
> Regards,
> 	Andre
> --
> Andre Vehreschild * Email: vehre ad gmx dot de

Re: [Fortran, Patch, PR 96992] Fix Class arrays of different ranks are rejected as storage association argument

[Andre Vehreschild]

[-- Attachment #1: Type: text/plain, Size: 626 bytes --]

Hi Harald,

thank you for the investigation and useful tips. I had to figure what went
wrong here, but I now figured, that the array needs repacking when a negative
stride is used (or at least a call to that routine, which then fixes "stuff").
I have added it, freeing the memory allocated potentially by pack, and also
updated the testcase to include the negative stride.

Regtests fine on x86_64-pc-linux-gnu/Fedora 39. Ok for mainline?

Regards,
	Andre

On Sun, 16 Jun 2024 23:27:46 +0200
Harald Anlauf <anlauf@gmx.de> wrote:

<< snipped for brevity >>>
--
Andre Vehreschild * Email: vehre ad gmx dot de

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: pr96992_2.patch --]
[-- Type: text/x-patch, Size: 6606 bytes --]

From c0c95afa95bb682385e47cc248f04e6eecd91e6d Mon Sep 17 00:00:00 2001
From: Andre Vehreschild <vehre@gcc.gnu.org>
Date: Fri, 14 Jun 2024 16:54:37 +0200
Subject: [PATCH] Fortran: Fix rejecting class arrays of different ranks as
 storage association argument.

Removing the assert in trans-expr, lead to initial strides not set
which is not fixed.  When the array needs repacking, this is done for
class arrays now, too.

	PR fortran/96992

gcc/fortran/ChangeLog:

	* trans-array.cc (gfc_trans_array_bounds): Set a starting
	stride, when descriptor expects a variable for the stride.
	(gfc_trans_dummy_array_bias): Allow storage association for
	dummy class arrays, when they are not elemental.
	* trans-expr.cc (gfc_conv_derived_to_class): Remove assert to
	allow converting derived to class type arrays with assumed
	rank.  Add packing when necessary.

gcc/testsuite/ChangeLog:

	* gfortran.dg/pr96992.f90: New test.
---
 gcc/fortran/trans-array.cc            |  7 ++-
 gcc/fortran/trans-expr.cc             | 31 ++++++++++++-
 gcc/testsuite/gfortran.dg/pr96992.f90 | 66 +++++++++++++++++++++++++++
 3 files changed, 101 insertions(+), 3 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/pr96992.f90

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 24a9a51692c..573e056d7c6 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -6798,6 +6798,9 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,

   size = gfc_index_one_node;
   offset = gfc_index_zero_node;
+  stride = GFC_TYPE_ARRAY_STRIDE (type, 0);
+  if (stride && VAR_P (stride))
+    gfc_add_modify (pblock, stride, gfc_index_one_node);
   for (dim = 0; dim < as->rank; dim++)
     {
       /* Evaluate non-constant array bound expressions.
@@ -7143,7 +7146,9 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
       || (is_classarray && CLASS_DATA (sym)->attr.allocatable))
     return;

-  if (!is_classarray && sym->attr.dummy && gfc_is_nodesc_array (sym))
+  if ((!is_classarray
+       || (is_classarray && CLASS_DATA (sym)->as->type == AS_EXPLICIT))
+      && sym->attr.dummy && !sym->attr.elemental && gfc_is_nodesc_array (sym))
     {
       gfc_trans_g77_array (sym, block);
       return;
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 0796fb75505..4468163e482 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -874,6 +874,7 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
 	  stmtblock_t block;
 	  gfc_init_block (&block);
 	  gfc_ref *ref;
+	  tree maybetmp = NULL_TREE, origdata = NULL_TREE;

 	  parmse->ss = ss;
 	  parmse->use_offset = 1;
@@ -903,8 +904,29 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,

 	  if (e->rank != class_ts.u.derived->components->as->rank)
 	    {
-	      gcc_assert (class_ts.u.derived->components->as->type
-			  == AS_ASSUMED_RANK);
+	      tree desc;
+
+	      desc = parmse->expr;
+	      if (VAR_P (desc) && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
+		  && !GFC_DECL_PACKED_ARRAY (desc)
+		  && !GFC_DECL_PARTIAL_PACKED_ARRAY (desc))
+		{
+		  origdata = gfc_evaluate_now (
+		    fold_convert (pvoid_type_node,
+				  gfc_conv_descriptor_data_get (desc)),
+		    &block);
+		  tmp = gfc_build_addr_expr (NULL, desc);
+		  tmp = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
+		  maybetmp = gfc_evaluate_now (tmp, &block);
+		  gfc_conv_descriptor_data_set (&block, desc, maybetmp);
+		  /* Add code to free eventually allocated temporary array
+		     from pack.  */
+		  tmp = fold_build2 (NE_EXPR, boolean_type_node, maybetmp,
+				     origdata);
+		  tmp = build3_v (COND_EXPR, tmp, gfc_call_free (maybetmp),
+				  build_empty_stmt (input_location));
+		  gfc_add_expr_to_block (&parmse->post, tmp);
+		}
 	      if (derived_array
 		  && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (parmse->expr)))
 		{
@@ -933,6 +955,11 @@ gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e,
 	      if (derived_array && *derived_array != NULL_TREE)
 		gfc_conv_descriptor_data_set (&block, *derived_array,
 					      null_pointer_node);
+	      if (maybetmp)
+		{
+		  gfc_add_modify (&block, maybetmp, null_pointer_node);
+		  gfc_add_modify (&block, origdata, null_pointer_node);
+		}

 	      tmp = build3_v (COND_EXPR, cond_optional, tmp,
 			      gfc_finish_block (&block));
diff --git a/gcc/testsuite/gfortran.dg/pr96992.f90 b/gcc/testsuite/gfortran.dg/pr96992.f90
new file mode 100644
index 00000000000..e4b38ef35f0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr96992.f90
@@ -0,0 +1,66 @@
+! { dg-do run }
+
+! PR fortran/96992
+
+! Contributed by Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+! From the standard:
+! An actual argument that represents an element sequence and
+! corresponds to a dummy argument that is an array is sequence
+! associated with the dummy argument. The rank and shape of the
+! actual argument need not agree with the rank and shape of the
+! dummy argument, but the number of elements in the dummy argument
+! shall not exceed the number of elements in the element sequence
+! of the actual argument. If the dummy argument is assumed-size,
+! the number of elements in the dummy argument is exactly
+! the number of elements in the element sequence.
+
+! Check that walking the sequence starts with an initialized stride
+! for dim == 0.
+
+module foo_mod
+  implicit none
+  type foo
+     integer :: i
+  end type foo
+contains
+  subroutine d1(x,n)
+    integer, intent(in) :: n
+    integer :: i
+    class (foo), intent(out), dimension(n) :: x
+    select type(x)
+    class is(foo)
+       x(:)%i = (/ (42 + i, i = 1, n ) /)
+    class default
+       stop 1
+    end select
+  end subroutine d1
+  subroutine d2(x,n)
+    integer, intent(in) :: n
+    integer :: i
+    class (foo), intent(in), dimension(n,n,n) :: x
+    select type (x)
+    class is (foo)
+       if ( any( x%i /= reshape((/ (42 + i, i = 1, n ** 3 ) /), [n, n, n] ))) stop 2
+    class default
+       stop 3
+    end select
+  end subroutine d2
+end module foo_mod
+program main
+  use foo_mod
+  implicit none
+  type (foo), dimension(:), allocatable :: f
+  integer :: n,i
+  n = 3
+  allocate (f(n*n*n))
+  call d1(f,n*n*n)
+  call d2(f,n)
+
+  ! Use negative stride
+  call d1(f(n*n*n:1:-1),n*n*n)
+  if ( any( f%i /= (/ (42 + i, i = n ** 3, 1, -1 ) /) )) stop 4
+  call d2(f(n*n*n:1:-1),n)
+  deallocate (f)
+end program main
+
--
2.45.2

Re: [Fortran, Patch, PR 96992] Fix Class arrays of different ranks are rejected as storage association argument

[Harald Anlauf]

Hi Andre,

Am 19.06.24 um 09:07 schrieb Andre Vehreschild:
> Hi Harald,
>
> thank you for the investigation and useful tips. I had to figure what went
> wrong here, but I now figured, that the array needs repacking when a negative
> stride is used (or at least a call to that routine, which then fixes "stuff").
> I have added it, freeing the memory allocated potentially by pack, and also
> updated the testcase to include the negative stride.

hmmm, the pack does not always get generated:

module foo_mod
   implicit none
   type foo
      integer :: i
   end type foo
contains
   subroutine d1(x,n)
     integer, intent(in) :: n
     integer :: i
     class (foo), intent(out) :: x(n)
     select type(x)
     class is(foo)
        x(:)%i = (/ (42 + i, i = 1, n ) /)
     class default
        stop 1
     end select
   end subroutine d1
   subroutine d2(x,n)
     integer, intent(in) :: n
     integer :: i
     class (foo), intent(in) :: x(n,n,n)
     select type (x)
     class is (foo)
        print *,"d2:  ", x%i
        if ( any( x%i /= reshape((/ (42 + i, i = 1, n ** 3 ) /), [n, n,
n] ))) stop 2
     class default
        stop 3
     end select
   end subroutine d2

   subroutine d3(x,n)
     integer, intent(in) :: n
     integer :: i
     class (foo), intent(inout) :: x(n)
     select type (x)
     class is (foo)
        print *,"d3_1:", x%i
        x%i = -x%i               ! Simply negate elements
        print *,"d3_2:", x%i
     class default
        stop 33
     end select
   end subroutine d3
end module foo_mod
program main
   use foo_mod
   implicit none
   type (foo), dimension(:), allocatable :: f
   integer :: n, k, m
   n = 2
   allocate (f(n*n*n))
   ! Original testcase:
   call d1(f,n*n*n)
   print *, "d1->:", f%i
   call d2(f,n)
   ! Ensure that array f is ok:
   print *, "d2->:", f%i

   ! The following shows that no appropriate internal pack is generated:
   call d1(f,n*n*n)
   print *, "d1->:", f%i
   m = n*n*n
   k = 3
   print *, "->d3:", f(1:m:k)%i
   call d3(f(1:m:k),1+(m-1)/k)
   print *, "d3->:", f(1:m:k)%i
   print *, "full:", f%i
   deallocate (f)
end program main


After the second version of your patch this prints:

  d1->:          43          44          45          46          47
     48          49          50
  d2:            43          44          45          46          47
     48          49          50
  d2->:          43          44          45          46          47
     48          49          50
  d1->:          43          44          45          46          47
     48          49          50
  ->d3:          43          46          49
  d3_1:          43          44          45
  d3_2:         -43         -44         -45
  d3->:         -43          46          49
  full:         -43         -44         -45          46          47
     48          49          50

While the print properly handles f(1:m:k)%i, passing it as
actual argument to subroutine d3 does not do pack/unpack.

Can you have another look?

Thanks,
Harald


> Regtests fine on x86_64-pc-linux-gnu/Fedora 39. Ok for mainline?
>
> Regards,
> 	Andre
>
> On Sun, 16 Jun 2024 23:27:46 +0200
> Harald Anlauf <anlauf@gmx.de> wrote:
>
> << snipped for brevity >>>
> --
> Andre Vehreschild * Email: vehre ad gmx dot de