https://gcc.gnu.org/g:3c970c69e4ce586030af3833d8bf6ec8e191fbbd
commit 3c970c69e4ce586030af3833d8bf6ec8e191fbbd
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Mon Jun 2 15:00:40 2025 +0200
Passage de subreferences sans copie
Diff:
---
gcc/fortran/trans-expr.cc | 4 +
.../gfortran.dg/array_subref_actual_arg_1.f90 | 186 +++++++++++++++++++++
gcc/testsuite/lib/scandump.exp | 50 ++++++
gcc/testsuite/lib/scantree.exp | 26 +++
4 files changed, 266 insertions(+)
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index fa54e2a5ae37..09cdea6e2b8b 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -7550,6 +7550,10 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
else if (e->expr_type == EXPR_VARIABLE
&& is_subref_array (e)
+ && !(fsym && fsym->as
+ && (fsym->as->type == AS_ASSUMED_SHAPE
+ || fsym->as->type == AS_ASSUMED_RANK
+ || fsym->as->type == AS_DEFERRED))
&& !(fsym && fsym->attr.pointer))
/* The actual argument is a component reference to an
array of derived types. In this case, the argument
diff --git a/gcc/testsuite/gfortran.dg/array_subref_actual_arg_1.f90
b/gcc/testsuite/gfortran.dg/array_subref_actual_arg_1.f90
new file mode 100644
index 000000000000..a52f9c39c320
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/array_subref_actual_arg_1.f90
@@ -0,0 +1,186 @@
+! { dg-do run }
+! { dg-additional-options "-Warray-temporaries -fdump-tree-original" }
+!
+! Check correct passing of subreference arrays, with either a descriptor
+! without data copy to a temporary, or no descriptor and data copy.
+!
+! We check the presence of temporaries in the dump based on the variable name
+! array descriptors that don't use a temporary are named PARM, whereas
variables
+! that do data copy are named ATMP.
+
+module m
+
+ implicit none
+ integer, parameter :: k = selected_int_kind (6)
+ type :: t
+ integer(kind=k) :: a, b
+ end type t
+ type, extends(t) :: u
+ integer(kind=k) :: c
+ end type u
+ integer, parameter :: s = 3 ! number of integers in a type u
+ integer, parameter :: r = 3 ! extent of x in each dimension
+ type(u) :: x(r, r)
+ integer, parameter :: dat(s*r*r) = (/ 2, 3, 5, 7, 11, 13, &
+ 17, 19, 23, 29, 31, 37, &
+ 41, 43, 47, 53, 59, 61, &
+ 67, 71, 73, 79, 83, 89, &
+ 97,101,103 /)
+
+contains
+
+ subroutine init(z)
+ type(u) :: z(:,:)
+ integer :: i, j
+ do j=1,r
+ associate (n => (j-1)*r*s)
+ do i = 1,r
+ associate(m => n+(i-1)*s)
+ associate(p => dat(m+1:m+s))
+ z(i,j) = u(p(1), p(2), p(3))
+ end associate
+ end associate
+ end do
+ end associate
+ end do
+ end subroutine init
+
+ subroutine check(z, i, j, p1, p2, error_code)
+ type(t), intent(in) :: z
+ integer, intent(in) :: i, j, error_code
+ integer(kind=k), intent(in) :: p1, p2
+ if (z%a /= p1 .or. z%b /= p2) then
+ print *, i, j
+ print *, z
+ print *, p1, p2
+ error stop error_code
+ end if
+ end subroutine check
+
+ subroutine sub_assumed_shape(y)
+ type(t), intent(in) :: y(:,:)
+ integer :: i, j
+ if (any(shape(y) /= shape(x))) error stop 1
+ do j=1,r
+ associate (n => (j-1)*r*s)
+ do i = 1,r
+ associate(m => n+(i-1)*s)
+ associate(p => dat(m+1:m+s))
+ call check(y(i,j), i, j, p(1), p(2), 2)
+ end associate
+ end associate
+ end do
+ end associate
+ end do
+ end subroutine sub_assumed_shape
+
+ subroutine sub_explicit(y)
+ type(t), intent(in) :: y(r,r)
+ integer :: i, j
+ if (any(shape(y) /= shape(x))) error stop 11
+ do j=1,r
+ associate (n => (j-1)*r*s)
+ do i = 1,r
+ associate(m => n+(i-1)*s)
+ associate(p => dat(m+1:m+s))
+ call check(y(i, j), i, j, p(1), p(2), 12)
+ end associate
+ end associate
+ end do
+ end associate
+ end do
+ end subroutine sub_explicit
+
+ subroutine sub_assumed_size(y)
+ type(t), intent(in) :: y(r,*)
+ integer :: i, j
+ if (size(y,1) /= size(x,1)) error stop 21
+ do j=1,r
+ associate (n => (j-1)*r*s)
+ do i = 1,r
+ associate(m => n+(i-1)*s)
+ associate(p => dat(m+1:m+s))
+ call check(y(i, j), i, j, p(1), p(2), 22)
+ end associate
+ end associate
+ end do
+ end associate
+ end do
+ end subroutine sub_assumed_size
+
+ subroutine sub_assumed_rank(y)
+ type(t), intent(in) :: y(..)
+ integer :: i, j
+ if (any(shape(y) /= shape(x))) error stop 41
+ select rank (y)
+ rank(2)
+ do j=1,r
+ associate (n => (j-1)*r*s)
+ do i = 1,r
+ associate(m => n+(i-1)*s)
+ associate(p => dat(m+1:m+s))
+ call check(y(i, j), i, j, p(1), p(2), 42)
+ end associate
+ end associate
+ end do
+ end associate
+ end do
+ rank default
+ error stop 43
+ end select
+ end subroutine sub_assumed_rank
+
+end module m
+
+subroutine sub_implicit(y)
+ use m
+ type(t), intent(in) :: y(r,r)
+ integer :: i, j
+ if (size(y,1) /= size(x,1)) error stop 31
+ do j=1,r
+ associate (n => (j-1)*r*s)
+ do i = 1,r
+ associate(m => n+(i-1)*s)
+ associate(p => dat(m+1:m+s))
+ call check(y(i, j), i, j, p(1), p(2), 32)
+ end associate
+ end associate
+ end do
+ end associate
+ end do
+end subroutine sub_implicit
+
+program p
+ use m
+ implicit none
+
+ call init(x)
+
+ ! Descriptor without data copy: one single usage of the data pointer for its
initialisation.
+ call sub_assumed_shape(x%t)
+ ! { dg-final { scan-tree-dump-var {sub_assumed_shape \(&parm\.(\d+)\);}
original ashp_parm_id } }
+ ! { dg-final { global ashp_parm_id; scan-tree-dump-times
"parm.${ashp_parm_id}\\.data" 1 original } }
+
+ ! Use a temporary; there are three usages of the data pointer: one for its
initialisation,
+ ! one for the data copy, and one for passing as actual argument
+ call sub_explicit(x%t) ! { dg-warning "array temporary" }
+ ! { dg-final { scan-tree-dump-var {sub_explicit \(\(.*?\)
atmp.(\d+)\.data\);} original expl_tmp_id } }
+ ! { dg-final { global expl_tmp_id; scan-tree-dump-times
"atmp.${expl_tmp_id}\\.data" 3 original } }
+
+ ! Use a temporary; there are three usages of the data pointer: one for its
initialisation,
+ ! one for the data copy, and one for passing as actual argument
+ call sub_assumed_size(x%t) ! { dg-warning "array temporary" }
+ ! { dg-final { scan-tree-dump-var {sub_assumed_size \(\(.*?\)
atmp.(\d+)\.data\);} original asz_tmp_id } }
+ ! { dg-final { global asz_tmp_id; scan-tree-dump-times
"atmp.${asz_tmp_id}\\.data" 3 original } }
+
+ ! Use a temporary; there are four usages of the data pointer: one for its
initialisation,
+ ! one for the data copy in, one for passing as actual argument, and one for
data copy out
+ call sub_implicit(x%t) ! { dg-warning "array temporary" }
+ ! { dg-final { scan-tree-dump-var {sub_implicit \(\(.*?\)
atmp.(\d+)\.data\);} original impl_tmp_id } }
+ ! { dg-final { global impl_tmp_id; scan-tree-dump-times
"atmp.${impl_tmp_id}\\.data" 4 original } }
+
+ ! Descriptor without data copy: one single usage of the data pointer for its
initialisation.
+ call sub_assumed_rank(x%t)
+ ! { dg-final { scan-tree-dump-var {sub_assumed_rank \(&parm\.(\d+)\);}
original arnk_parm_id } }
+ ! { dg-final { global arnk_parm_id; scan-tree-dump-times
"parm.${arnk_parm_id}\\.data" 1 original } }
+end program p
diff --git a/gcc/testsuite/lib/scandump.exp b/gcc/testsuite/lib/scandump.exp
index a8441daa22fa..74a77f0a57e1 100644
--- a/gcc/testsuite/lib/scandump.exp
+++ b/gcc/testsuite/lib/scandump.exp
@@ -214,6 +214,56 @@ proc scan-dump-not { args } {
}
}
+# Utility for scanning compiler result, invoked via dg-final.
+# Call pass if pattern is present, otherwise fail.
+#
+# Argument 0 is the type of dump we are searching (rtl, tree, ipa)
+# Argument 1 is the regexp to match.
+# Argument 2 is the suffix for the dump file
+# Argument 3 is the suffix of the dump base
+# Argument 4 is the variable name to store the matched content
+# Argument 5 handles expected failures and the like
+proc scan-dump-var { args } {
+
+ if { [llength $args] >= 6 } {
+ switch [dg-process-target [lindex $args 5]] {
+ "S" { }
+ "N" { return }
+ "F" { setup_xfail "*-*-*" }
+ "P" { }
+ }
+ }
+
+ set testcase [testname-for-summary]
+ # The name might include a list of options; extract the file name.
+ set filename [lindex $testcase 0]
+
+ set printable_pattern [make_pattern_printable [lindex $args 1]]
+ set suf [dump-suffix [lindex $args 2]]
+ set testname "$testcase scan-[lindex $args 0]-dump $suf
\"$printable_pattern\""
+ set src [file tail $filename]
+ set dumpbase [dump-base $src [lindex $args 3]]
+
+ set pattern "$dumpbase.[lindex $args 2]"
+ set output_file "[glob-dump-file $testcase $pattern]"
+ if { $output_file == "" } {
+ unresolved "$testname"
+ return
+ }
+
+ set fd [open $output_file r]
+ set text [read $fd]
+ close $fd
+
+ global [lindex $args 4]
+ set [lindex $args 4] {}
+ if [regexp -- [lindex $args 1] $text scratch [lindex $args 4]] {
+ pass "$testname"
+ } else {
+ fail "$testname"
+ }
+}
+
# Utility for scanning demangled compiler result, invoked via dg-final.
# Call pass if pattern is present, otherwise fail.
#
diff --git a/gcc/testsuite/lib/scantree.exp b/gcc/testsuite/lib/scantree.exp
index 833ac387eb4b..b67713e11cbf 100644
--- a/gcc/testsuite/lib/scantree.exp
+++ b/gcc/testsuite/lib/scantree.exp
@@ -94,6 +94,32 @@ proc scan-tree-dump-not { args } {
}
}
+# Utility for scanning compiler result, invoked via dg-final.
+# Call pass if pattern is present, otherwise fail.
+#
+# Argument 0 is the regexp to match
+# Argument 1 is the name of the dumped tree pass
+# Argument 2 is the variable name to store the matched content
+# Argument 3 handles expected failures and the like
+proc scan-tree-dump-var { args } {
+
+ if { [llength $args] < 3 } {
+ error "scan-tree-dump-var: too few arguments"
+ return
+ }
+ if { [llength $args] > 4 } {
+ error "scan-tree-dump-var: too many arguments"
+ return
+ }
+ if { [llength $args] >= 4 } {
+ scan-dump-var "tree" [lindex $args 0] \
+ "\[0-9\]\[0-9\]\[0-9\]t.[lindex $args 1]" "" [lindex $args 2]
[lindex $args 3]
+ } else {
+ scan-dump-var "tree" [lindex $args 0] \
+ "\[0-9\]\[0-9\]\[0-9\]t.[lindex $args 1]" "" [lindex $args 2]
+ }
+}
+
# Utility for scanning demangled compiler result, invoked via dg-final.
# Call pass if pattern is present, otherwise fail.
#
