diff mbox series

Fortran: fix argument passing to CONTIGUOUS,TARGET dummy [PR97592]

Message ID trinity-aad8c14c-b211-4687-96a9-db32950c47a1-1702751317953@3c-app-gmx-bs38
State Accepted
Headers
Series Fortran: fix argument passing to CONTIGUOUS,TARGET dummy [PR97592] |

Checks

Context Check Description
snail/gcc-patch-check success Github commit url

Commit Message

Harald Anlauf Dec. 16, 2023, 6:28 p.m. UTC 
  Dear all,

the attached simple patch fixes a (9+) regression for passing
to a CONTIGUOUS,TARGET dummy an *effective argument* that is
contiguous, although the actual argument is not simply-contiguous
(it is a pointer without the CONTIGOUS attribute in the PR).

Since a previous attempt for a patch lead to regressions in
gfortran.dg/bind-c-contiguous-3.f90, which is rather dense,
I decided to enhance the current testcase with various
combinations of actual and dummy arguments that allow to
study whether a _gfortran_internal_pack is generated in
places where we want to.  (_gfortran_internal_pack does not
create a temporary when no packing is needed).

Regtested on x86_64-pc-linux-gnu.  OK for mainline?

I would like to backport this - after a grace period - to
at least 13-branch.  Any objections here?

Thanks,
Harald

Comments

Paul Richard Thomas Dec. 17, 2023, 4:08 p.m. UTC | #1 
Hi Harald,

It might be a simple patch but I have to confess it took a while for me to
get my head around the difference between gfc_is_not_contiguous and
!gfc_is_simply_contigous :-(

Yes, this is OK for mainline and, after a short delay, for 13-branch.

Thanks for the patch

Paul


On Sat, 16 Dec 2023 at 18:28, Harald Anlauf <anlauf@gmx.de> wrote:

> Dear all,
>
> the attached simple patch fixes a (9+) regression for passing
> to a CONTIGUOUS,TARGET dummy an *effective argument* that is
> contiguous, although the actual argument is not simply-contiguous
> (it is a pointer without the CONTIGOUS attribute in the PR).
>
> Since a previous attempt for a patch lead to regressions in
> gfortran.dg/bind-c-contiguous-3.f90, which is rather dense,
> I decided to enhance the current testcase with various
> combinations of actual and dummy arguments that allow to
> study whether a _gfortran_internal_pack is generated in
> places where we want to.  (_gfortran_internal_pack does not
> create a temporary when no packing is needed).
>
> Regtested on x86_64-pc-linux-gnu.  OK for mainline?
>
> I would like to backport this - after a grace period - to
> at least 13-branch.  Any objections here?
>
> Thanks,
> Harald
>
>
diff mbox series

Patch

From d8765bd669e501781672c0bec976b2f5fd7acff6 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anlauf@gmx.de>
Date: Sat, 16 Dec 2023 19:14:55 +0100
Subject: [PATCH] Fortran: fix argument passing to CONTIGUOUS,TARGET dummy
 [PR97592]

gcc/fortran/ChangeLog:

	PR fortran/97592
	* trans-expr.cc (gfc_conv_procedure_call): For a contiguous dummy
	with the TARGET attribute, the effective argument may still be
	contiguous even if the actual argument is not simply-contiguous.
	Allow packing to be decided at runtime by _gfortran_internal_pack.

gcc/testsuite/ChangeLog:

	PR fortran/97592
	* gfortran.dg/contiguous_15.f90: New test.
---
 gcc/fortran/trans-expr.cc                   |   4 +-
 gcc/testsuite/gfortran.dg/contiguous_15.f90 | 234 ++++++++++++++++++++
 2 files changed, 237 insertions(+), 1 deletion(-)
 create mode 100644 gcc/testsuite/gfortran.dg/contiguous_15.f90

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index f4185db5b7f..218fede6a82 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -7124,7 +7124,9 @@  gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
 					     INTENT_IN, fsym->attr.pointer);
 		}
 	      else if (fsym && fsym->attr.contiguous
-		       && !gfc_is_simply_contiguous (e, false, true)
+		       && (fsym->attr.target
+			   ? gfc_is_not_contiguous (e)
+			   : !gfc_is_simply_contiguous (e, false, true))
 		       && gfc_expr_is_variable (e))
 		{
 		  gfc_conv_subref_array_arg (&parmse, e, nodesc_arg,
diff --git a/gcc/testsuite/gfortran.dg/contiguous_15.f90 b/gcc/testsuite/gfortran.dg/contiguous_15.f90
new file mode 100644
index 00000000000..424eb080fd1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/contiguous_15.f90
@@ -0,0 +1,234 @@ 
+! { dg-do run }
+! { dg-additional-options "-fdump-tree-original" }
+!
+! PR fortran/97592 - fix argument passing to CONTIGUOUS,TARGET dummy
+!
+! { dg-final { scan-tree-dump-times "_gfortran_internal_pack \\(&b_2d" 1 "original" } }
+! { dg-final { scan-tree-dump-times "_gfortran_internal_pack \\(&p1" 3 "original" } }
+!
+! N.B.: there is no reliable count of _gfortran_internal_pack on temporaries parm.*
+
+program pr97592
+  implicit none
+  integer :: i, k
+  integer, target              :: a(10)
+  integer, pointer             :: p1(:), p2(:), tgt(:), expect(:)
+  integer, pointer, contiguous :: cp(:)
+  integer, allocatable, target :: b(:)
+
+  !----------------------
+  ! Code from original PR
+  !----------------------
+  call RemappingTest ()
+
+  !---------------------
+  ! Additional 1-d tests
+  !---------------------
+  a = [(i, i=1,size(a))]
+  b = a
+
+  ! Set p1 to an actually contiguous pointer
+  p1(13:) => a(3::2)
+  print *, lbound (p1), ubound (p1), is_contiguous (p1)
+
+  ! non-contiguous pointer actual argument
+  expect => p1
+  call chk_cont (p1)
+
+  expect => p1
+  call chk_tgt_cont (p1)
+
+  expect => p1
+  call chk_ptr  (p1, p2)
+  if (any (p2 /= p1)) stop 1
+
+  expect => p1
+  call chk_tgt  (p1, p2)
+  if (any (p2 /= p1)) stop 2
+
+  ! non-contiguous target actual argument
+  expect => b(3::2)
+  call chk_tgt_cont (b(3::2))
+
+  expect => b(3::2)
+  call chk_tgt (b(3::2), p2)
+  if (any (p2 /= p1)) stop 3
+
+  expect => b(3::2)
+  call chk_ptr  (b(3::2), p2)
+  if (any (p2 /= p1)) stop 4
+
+  ! Set p1 to an actually contiguous pointer
+  cp(17:) => a(3:9:1)
+  p1 => cp
+  print *, lbound (cp), ubound (cp), is_contiguous (cp)
+  print *, lbound (p1), ubound (p1), is_contiguous (p1)
+
+  expect => p1
+  call chk_tgt  (p1, p2)
+  if (any (p2 /= cp)) stop 31
+
+  expect => cp
+  call chk_tgt  (cp, p2)
+  if (any (p2 /= cp)) stop 32
+
+  expect => cp
+  call chk_tgt_cont (cp, p2)
+  if (any (p2 /= cp)) stop 33
+
+  expect => cp
+  call chk_tgt_expl (cp, p2, size (cp))
+  if (any (p2 /= cp)) stop 34
+
+  ! See F2018:15.5.2.4 and F2018:C.10.4
+  expect => p1
+  call chk_tgt_cont (p1, p2)
+! print *, p2
+  if (any (p2 /= cp)) stop 35
+
+  expect => p1
+  call chk_tgt_expl (p1, p2, size (p1))
+  if (any (p2 /= cp)) stop 36
+
+  expect => cp
+  call chk_ptr_cont (cp, p2)
+  if (any (p2 /= cp)) stop 37
+
+  ! Pass array section which is actually contigous
+  k = 1
+  expect => cp(::k)
+  call chk_ptr (cp(::k), p2)
+  if (any (p2 /= cp(::k))) stop 38
+
+  expect => p1(::k)
+  call chk_tgt_cont (p1(::k), p2)
+  if (any (p2 /= p1(::k))) stop 39
+
+  expect => p1(::k)
+  call chk_tgt (p1(::k), p2)
+  if (any (p2 /= p1(::k))) stop 40
+
+  expect => p1(::k)
+  call chk_tgt_expl (p1(::k), p2, size (p1(::k)))
+  if (any (p2 /= p1(::k))) stop 41
+
+  expect => b(3::k)
+  call chk_tgt_cont (b(3::k), p2)
+  if (any (p2 /= b(3::k))) stop 42
+
+  expect => b(3::k)
+  call chk_tgt (b(3::k), p2)
+  if (any (p2 /= b(3::k))) stop 43
+
+  expect => b(3::k)
+  call chk_tgt_expl (b(3::k), p2, size (b(3::k)))
+  if (any (p2 /= b(3::k))) stop 44
+
+  if (any (a /= [(i, i=1,size(a))])) stop 66
+  if (any (a /= b))                  stop 77
+  deallocate (b)
+
+contains
+  ! Contiguous pointer dummy
+  subroutine chk_ptr_cont (x, y)
+    integer, contiguous, pointer, intent(in) :: x(:)
+    integer, pointer,    optional            :: y(:)
+    print *, lbound (x), ubound (x)
+    if (present (y)) y => x(:)
+    if (associated (expect)) then
+       if (size (x) /= size (expect)) stop 10
+       if (any (x /= expect))         stop 11
+       if (lbound(expect,1) /= 1   .and.   &
+           lbound(expect,1) /= lbound (x,1)) stop 20
+    end if
+  end
+
+  ! Pointer dummy
+  subroutine chk_ptr (x, y)
+    integer, pointer, intent(in) :: x(:)
+    integer, pointer, optional   :: y(:)
+    print *, lbound (x), ubound (x)
+    if (present (y)) y => x(:)
+    if (associated (expect)) then
+       if (size (x) /= size (expect)) stop 12
+       if (any (x /= expect))         stop 13
+       if (lbound(expect,1) /= 1   .and.   &
+           lbound(expect,1) /= lbound (x,1)) stop 22
+    end if
+  end
+
+  ! Dummy with target attribute
+  subroutine chk_tgt_cont (x, y)
+    integer, contiguous, target,  intent(in) :: x(:)
+    integer, pointer,    optional            :: y(:)
+    if (present (y)) y => x(:)
+    if (associated (expect)) then
+       if (size (x) /= size (expect)) stop 14
+       if (any (x /= expect))         stop 15
+    end if
+  end
+
+  subroutine chk_tgt (x, y)
+    integer, target,  intent(in) :: x(:)
+    integer, pointer, optional   :: y(:)
+    if (present (y)) y => x(:)
+    if (associated (expect)) then
+       if (size (x) /= size (expect)) stop 16
+       if (any (x /= expect))         stop 17
+    end if
+  end
+
+  ! Explicit-shape dummy with target attribute
+  subroutine chk_tgt_expl (x, y, n)
+    integer,         intent(in) :: n
+    integer, target, intent(in) :: x(n)
+    integer, pointer, optional  :: y(:)
+    if (present (y)) y => x(:)
+    if (associated (expect)) then
+       if (size (x) /= size (expect)) stop 18
+       if (any (x /= expect))         stop 19
+    end if
+  end
+
+  ! Dummy without pointer or target attribute
+  subroutine chk_cont (x)
+    integer, contiguous, intent(in) :: x(:)
+    if (associated (expect)) then
+       if (size (x) /= size (expect)) stop 23
+       if (any (x /= expect))         stop 24
+    end if
+  end
+
+  !------------------------------------------------------------------------
+
+  subroutine RemappingTest ()
+    real, pointer      :: B_2D(:,:)
+    real, pointer      :: B_3D(:,:,:) => NULL()
+    integer, parameter :: n1=4, n2=4, n3=3
+    !-- Prepare B_2D
+    allocate (B_2D(n1*n2, n3))
+    B_2D = - huge (1.0)
+    if (.not. is_contiguous (B_2D)) stop 101
+    !-- Point B_3D to Storage
+    call SetPointer (B_2D, n1, n2, n3, B_3D)
+    !print *,"is_contiguous (B_3D) =", is_contiguous (B_3D)
+    if (.not. is_contiguous (B_3D)) stop 102
+    !-- Set B_3D
+    B_3D = 2.0
+    !-- See if the result is reflected in Storage
+    if (any (B_2D /= 2.0)) then
+       print *, "B_2D = ", B_2D  !-- expect 2.0 for all elements
+       stop 103
+    end if
+    print *,"RemappingTest passed"
+  end
+
+  subroutine SetPointer (C_2D, n1, n2, n3, C_3D)
+    integer,       intent(in) :: n1, n2, n3
+    real, target,  contiguous :: C_2D(:,:)
+    real, pointer             :: C_3D(:,:,:)
+    intent(in)                :: C_2D
+    C_3D(1:n1,1:n2,1:n3) => C_2D
+  end
+
+end
--
2.35.3