[gcc r12-6191] Fortran: Fix array copy-in/copy-out for BIND(C) functions [PR103390]

[gcc r12-6191] Fortran: Fix array copy-in/copy-out for BIND(C) functions [PR103390]

[Sandra Loosemore]

https://gcc.gnu.org/g:6447f6f983ffeaecb8753ef685d702bf2594968b

commit r12-6191-g6447f6f983ffeaecb8753ef685d702bf2594968b
Author: Sandra Loosemore <sandra@codesourcery.com>
Date:   Mon Jan 3 08:47:38 2022 -0800

    Fortran: Fix array copy-in/copy-out for BIND(C) functions [PR103390]
    
    The Fortran front end was generating invalid code for the array
    copy-out after a call to a BIND(C) function for a dummy with the
    CONTIGUOUS attribute when the actual argument was a call to the SHAPE
    intrinsic or other array expressions that are not lvalues.  It was
    also generating code to evaluate the argument expression multiple
    times on copy-in.  This patch teaches it to recognize that a copy is
    not needed in these cases.
    
    2022-01-03  Sandra Loosemore  <sandra@codesourcery.com>
    
            PR fortran/103390
    
            gcc/fortran/
            * expr.c (gfc_is_simply_contiguous): Make it smarter about
            function calls.
            * trans-expr.c (gfc_conv_gfc_desc_to_cfi_desc): Do not generate
            copy loops for array expressions that are not "variables" (lvalues).
    
            gcc/testsuite/
            * gfortran.dg/c-interop/pr103390-1.f90: New.
            * gfortran.dg/c-interop/pr103390-2.f90: New.
            * gfortran.dg/c-interop/pr103390-3.f90: New.
            * gfortran.dg/c-interop/pr103390-4.f90: New.
            * gfortran.dg/c-interop/pr103390-6.f90: New.
            * gfortran.dg/c-interop/pr103390-7.f90: New.
            * gfortran.dg/c-interop/pr103390-8.f90: New.
            * gfortran.dg/c-interop/pr103390-9.f90: New.

Diff:
---
 gcc/fortran/expr.c                                 | 12 +++++++--
 gcc/fortran/trans-expr.c                           | 10 ++++++--
 gcc/testsuite/gfortran.dg/c-interop/pr103390-1.f90 | 23 +++++++++++++++++
 gcc/testsuite/gfortran.dg/c-interop/pr103390-2.f90 | 20 +++++++++++++++
 gcc/testsuite/gfortran.dg/c-interop/pr103390-3.f90 | 29 ++++++++++++++++++++++
 gcc/testsuite/gfortran.dg/c-interop/pr103390-4.f90 | 25 +++++++++++++++++++
 gcc/testsuite/gfortran.dg/c-interop/pr103390-5.f90 | 26 +++++++++++++++++++
 gcc/testsuite/gfortran.dg/c-interop/pr103390-6.f90 | 22 ++++++++++++++++
 gcc/testsuite/gfortran.dg/c-interop/pr103390-7.f90 | 19 ++++++++++++++
 gcc/testsuite/gfortran.dg/c-interop/pr103390-8.f90 | 20 +++++++++++++++
 gcc/testsuite/gfortran.dg/c-interop/pr103390-9.f90 | 26 +++++++++++++++++++
 11 files changed, 228 insertions(+), 4 deletions(-)

diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index eb925276237..96a2cd70900 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -5883,8 +5883,16 @@ gfc_is_simply_contiguous (gfc_expr *expr, bool strict, bool permit_element)
 
   if (expr->expr_type == EXPR_FUNCTION)
     {
-      if (expr->value.function.esym)
-	return expr->value.function.esym->result->attr.contiguous;
+      if (expr->value.function.isym)
+	/* TRANSPOSE is the only intrinsic that may return a
+	   non-contiguous array.  It's treated as a special case in
+	   gfc_conv_expr_descriptor too.  */
+	return (expr->value.function.isym->id != GFC_ISYM_TRANSPOSE);
+      else if (expr->value.function.esym)
+	/* Only a pointer to an array without the contiguous attribute
+	   can be non-contiguous as a result value.  */
+	return (expr->value.function.esym->result->attr.contiguous
+		|| !expr->value.function.esym->result->attr.pointer);
       else
 	{
 	  /* Type-bound procedures.  */
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index df20db95782..381915e2a76 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -5536,13 +5536,17 @@ gfc_conv_gfc_desc_to_cfi_desc (gfc_se *parmse, gfc_expr *e, gfc_symbol *fsym)
     {
       /* If the actual argument can be noncontiguous, copy-in/out is required,
 	 if the dummy has either the CONTIGUOUS attribute or is an assumed-
-	 length assumed-length/assumed-size CHARACTER array.  */
+	 length assumed-length/assumed-size CHARACTER array.  This only
+	 applies if the actual argument is a "variable"; if it's some
+	 non-lvalue expression, we are going to evaluate it to a
+	 temporary below anyway.  */
       se.force_no_tmp = 1;
       if ((fsym->attr.contiguous
 	   || (fsym->ts.type == BT_CHARACTER && !fsym->ts.u.cl->length
 	       && (fsym->as->type == AS_ASSUMED_SIZE
 		   || fsym->as->type == AS_EXPLICIT)))
-	  && !gfc_is_simply_contiguous (e, false, true))
+	  && !gfc_is_simply_contiguous (e, false, true)
+	  && gfc_expr_is_variable (e))
 	{
 	  bool optional = fsym->attr.optional;
 	  fsym->attr.optional = 0;
@@ -6841,6 +6845,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 					     fsym->attr.pointer);
 		}
 	      else
+		/* This is where we introduce a temporary to store the
+		   result of a non-lvalue array expression.  */
 		gfc_conv_array_parameter (&parmse, e, nodesc_arg, fsym,
 					  sym->name, NULL);
 
diff --git a/gcc/testsuite/gfortran.dg/c-interop/pr103390-1.f90 b/gcc/testsuite/gfortran.dg/c-interop/pr103390-1.f90
new file mode 100644
index 00000000000..52d8835b164
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/pr103390-1.f90
@@ -0,0 +1,23 @@
+! { dg-do run }
+! { dg-options "-fdump-tree-original" }
+!
+! This program used to ICE in gimplification on the call to S, because it
+! was trying to copy out the array after the call to something that wasn't
+! an lvalue.
+
+program p
+   integer, pointer :: z(:)
+   integer, target :: x(3) = [1, 2, 3]
+   z => x
+   call s(shape(z))
+contains
+   subroutine s(x) bind(c)
+      integer, contiguous :: x(:)
+   end
+end
+
+! It should not emit any copy loops, just the loop for inlining SHAPE.
+! { dg-final { scan-tree-dump-times "while \\(1\\)" 1 "original" } }
+
+! It should not emit code to check the contiguous property.
+! { dg-final { scan-tree-dump-not "contiguous\\.\[0-9\]+" "original" } }
diff --git a/gcc/testsuite/gfortran.dg/c-interop/pr103390-2.f90 b/gcc/testsuite/gfortran.dg/c-interop/pr103390-2.f90
new file mode 100644
index 00000000000..771d81d2310
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/pr103390-2.f90
@@ -0,0 +1,20 @@
+! { dg-do run }
+! { dg-options "-fdump-tree-original" }
+!
+! Check that copy loops to ensure contiguity of transpose result are
+! still generated after fixing pr103390, and that it does not ICE.
+
+program p
+   integer, pointer :: z(:,:)
+   integer, target :: x(3,3) = reshape ([1, 2, 3, 4, 5, 6, 7, 8, 9], shape(x))
+   z => x
+   call s(transpose(z))
+contains
+   subroutine s(x) bind(c)
+      integer, contiguous :: x(:,:)
+   end
+end
+
+! Expect 2 nested copy loops both before and after the call to S.  
+! { dg-final { scan-tree-dump-times "while \\(1\\)" 4 "original" } }
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/pr103390-3.f90 b/gcc/testsuite/gfortran.dg/c-interop/pr103390-3.f90
new file mode 100644
index 00000000000..bd350114bb3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/pr103390-3.f90
@@ -0,0 +1,29 @@
+! { dg-do run }
+! { dg-options "-fdump-tree-original" }
+!
+! Check that copy loops to ensure contiguity of the result of a function
+! that returns a non-pointer array are generated properly after fixing
+! pr103390, and that it does not ICE.  In this case no copying is required.
+
+program p
+   integer, pointer :: z(:)
+   integer, target :: x(3) = [1, 2, 3]
+   z => x
+   call s(i(z))
+contains
+   function i(x)
+      integer :: i(3)
+      integer, pointer :: x(:)
+      i = x
+   end
+   subroutine s(x) bind(c)
+      integer, contiguous :: x(:)
+   end
+end
+
+! Expect one loop to copy the array contents to a temporary in function i.
+! { dg-final { scan-tree-dump-times "while \\(1\\)" 1 "original" } }
+
+! It should not emit code to check the contiguous property.
+! { dg-final { scan-tree-dump-not "contiguous\\.\[0-9\]+" "original" } }
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/pr103390-4.f90 b/gcc/testsuite/gfortran.dg/c-interop/pr103390-4.f90
new file mode 100644
index 00000000000..b8b64edf817
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/pr103390-4.f90
@@ -0,0 +1,25 @@
+! { dg-do run }
+! { dg-options "-fdump-tree-original" }
+!
+! Check that copy loops to ensure contiguity of the result of a function
+! that returns a pointer to an array are generated properly after fixing
+! pr103390, and that it does not ICE.
+
+program p
+   integer, pointer :: z(:)
+   integer, target :: x(3) = [1, 2, 3]
+   z => x
+   call s(i(z))
+contains
+   function i(x)
+      integer, pointer :: i(:)
+      integer, pointer :: x(:)
+      i => x
+   end
+   subroutine s(x) bind(c)
+      integer, contiguous :: x(:)
+   end
+end
+
+! Expect a copy loop both before and after the call to S.  
+! { dg-final { scan-tree-dump-times "while \\(1\\)" 2 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/c-interop/pr103390-5.f90 b/gcc/testsuite/gfortran.dg/c-interop/pr103390-5.f90
new file mode 100644
index 00000000000..c87b9793533
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/pr103390-5.f90
@@ -0,0 +1,26 @@
+! { dg-do run }
+! { dg-options "-fdump-tree-original" }
+!
+! Check that copy loops to ensure contiguity of the result of a function
+! that returns a pointer to an array are generated properly after fixing
+! pr103390, and that it does not ICE.  This variant is for an intent(in)
+! dummy argument so no copy-out is needed, only copy-in.
+
+program p
+   integer, pointer :: z(:)
+   integer, target :: x(3) = [1, 2, 3]
+   z => x
+   call s(i(z))
+contains
+   function i(x)
+      integer, pointer :: i(:)
+      integer, pointer :: x(:)
+      i => x
+   end
+   subroutine s(x) bind(c)
+      integer, contiguous, intent(in) :: x(:)
+   end
+end
+
+! Expect a copy loop before the call to S.  
+! { dg-final { scan-tree-dump-times "while \\(1\\)" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/c-interop/pr103390-6.f90 b/gcc/testsuite/gfortran.dg/c-interop/pr103390-6.f90
new file mode 100644
index 00000000000..394525b6675
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/pr103390-6.f90
@@ -0,0 +1,22 @@
+! { dg-do run }
+! { dg-options "-fdump-tree-original" }
+!
+! Check that copy loops to ensure contiguity of transpose result are
+! generated properly after fixing pr103390, and that it does not ICE.
+! This variant is for an intent(in) dummy argument so no copy-out
+! is needed, only copy-in.
+
+program p
+   integer, pointer :: z(:,:)
+   integer, target :: x(3,3) = reshape ([1, 2, 3, 4, 5, 6, 7, 8, 9], shape(x))
+   z => x
+   call s(transpose(z))
+contains
+   subroutine s(x) bind(c)
+      integer, contiguous, intent(in) :: x(:,:)
+   end
+end
+
+! Expect 2 nested copy loops before the call to S.  
+! { dg-final { scan-tree-dump-times "while \\(1\\)" 2 "original" } }
+
diff --git a/gcc/testsuite/gfortran.dg/c-interop/pr103390-7.f90 b/gcc/testsuite/gfortran.dg/c-interop/pr103390-7.f90
new file mode 100644
index 00000000000..d86dc79e19d
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/pr103390-7.f90
@@ -0,0 +1,19 @@
+! { dg-do run }
+! { dg-options "-fdump-tree-original" }
+!
+! Check that copy loops to ensure contiguity of the result of an array
+! section expression are generated properly after fixing pr103390, and
+! that it does not ICE.
+
+program p
+   integer, pointer :: z(:)
+   integer :: A(5) = [1, 2, 3, 4, 5]
+   call s(A(::2))
+contains
+   subroutine s(x) bind(c)
+      integer, contiguous :: x(:)
+   end
+end
+
+! Expect copy loops before and after the call to S.  
+! { dg-final { scan-tree-dump-times "while \\(1\\)" 2 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/c-interop/pr103390-8.f90 b/gcc/testsuite/gfortran.dg/c-interop/pr103390-8.f90
new file mode 100644
index 00000000000..3a3b3a8def5
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/pr103390-8.f90
@@ -0,0 +1,20 @@
+! { dg-do run }
+! { dg-options "-fdump-tree-original" }
+!
+! Check that copy loops to ensure contiguity of the result of an array
+! section expression are generated properly after fixing pr103390,
+! and that it does not ICE.  This case is for an intent(in)
+! dummy so no copy-out should occur, only copy-in.
+
+program p
+   integer, pointer :: z(:)
+   integer, parameter :: A(5) = [1, 2, 3, 4, 5]
+   call s(A(::2))
+contains
+   subroutine s(x) bind(c)
+      integer, contiguous, intent(in) :: x(:)
+   end
+end
+
+! Expect a copy loop before the call to S.  
+! { dg-final { scan-tree-dump-times "while \\(1\\)" 1 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/c-interop/pr103390-9.f90 b/gcc/testsuite/gfortran.dg/c-interop/pr103390-9.f90
new file mode 100644
index 00000000000..0d655b53883
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/c-interop/pr103390-9.f90
@@ -0,0 +1,26 @@
+! { dg-do run }
+! { dg-options "-fdump-tree-original" }
+!
+! Check that copy loops to ensure contiguity of the result of an elemental
+! array-valued expression are generated properly after fixing pr103390,
+! and that it does not ICE.
+
+program p
+   integer, pointer :: z(:)
+   integer :: a(3) = [1, 2, 3];
+   integer :: b(3) = [4, 5, 6];
+   call s(a + b);
+contains
+   subroutine s(x) bind(c)
+      integer, contiguous :: x(:)
+   end
+end
+
+! We only expect one loop before the call, to fill in the contiguous
+! temporary.  No copy-out is needed since the temporary is effectively
+! an rvalue.
+! { dg-final { scan-tree-dump-times "while \\(1\\)" 1 "original" } }
+
+! It should not emit code to check the contiguous property.
+! { dg-final { scan-tree-dump-not "contiguous\\.\[0-9\]+" "original" } }
+