https://gcc.gnu.org/g:d4df61dc6ed90e6614db213119858adde939fc97
commit r14-11245-gd4df61dc6ed90e6614db213119858adde939fc97
Author: Harald Anlauf <anl...@gmx.de>
Date: Sun Jan 19 21:06:56 2025 +0100
Fortran: do not copy back for parameter actual arguments [PR81978]
When an array is packed for passing as an actual argument, and the array
has the PARAMETER attribute (i.e., it is a named constant that can reside
in read-only memory), do not copy back (unpack) from the temporary.
PR fortran/81978
gcc/fortran/ChangeLog:
* trans-array.cc (gfc_conv_array_parameter): Do not copy back data
if actual array parameter has the PARAMETER attribute.
* trans-expr.cc (gfc_conv_subref_array_arg): Likewise.
gcc/testsuite/ChangeLog:
* gfortran.dg/pr81978.f90: New test.
(cherry picked from commit 0d1e62b83561baa185bf080515750a89dd3ac410)
Diff:
---
gcc/fortran/trans-array.cc | 10 +++-
gcc/fortran/trans-expr.cc | 11 +++-
gcc/testsuite/gfortran.dg/pr81978.f90 | 107 ++++++++++++++++++++++++++++++++++
3 files changed, 124 insertions(+), 4 deletions(-)
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index d9aaa9bceae4..61f641aa4918 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -8653,6 +8653,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr,
bool g77,
bool good_allocatable;
bool ultimate_ptr_comp;
bool ultimate_alloc_comp;
+ bool readonly;
gfc_symbol *sym;
stmtblock_t block;
gfc_ref *ref;
@@ -9007,8 +9008,13 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr,
bool g77,
gfc_start_block (&block);
- /* Copy the data back. */
- if (fsym == NULL || fsym->attr.intent != INTENT_IN)
+ /* Copy the data back. If input expr is read-only, e.g. a PARAMETER
+ array, copying back modified values is undefined behavior. */
+ readonly = (expr->expr_type == EXPR_VARIABLE
+ && expr->symtree
+ && expr->symtree->n.sym->attr.flavor == FL_PARAMETER);
+
+ if ((fsym == NULL || fsym->attr.intent != INTENT_IN) && !readonly)
{
tmp = build_call_expr_loc (input_location,
gfor_fndecl_in_unpack, 2, desc, ptr);
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 8e74fbfb257d..1efe435f397f 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -5028,6 +5028,7 @@ gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr,
int g77,
gfc_se work_se;
gfc_se *parmse;
bool pass_optional;
+ bool readonly;
pass_optional = fsym && fsym->attr.optional && sym && sym->attr.optional;
@@ -5244,8 +5245,14 @@ gfc_conv_subref_array_arg (gfc_se *se, gfc_expr * expr,
int g77,
/* Wrap the whole thing up by adding the second loop to the post-block
and following it by the post-block of the first loop. In this way,
- if the temporary needs freeing, it is done after use! */
- if (intent != INTENT_IN)
+ if the temporary needs freeing, it is done after use!
+ If input expr is read-only, e.g. a PARAMETER array, copying back
+ modified values is undefined behavior. */
+ readonly = (expr->expr_type == EXPR_VARIABLE
+ && expr->symtree
+ && expr->symtree->n.sym->attr.flavor == FL_PARAMETER);
+
+ if ((intent != INTENT_IN) && !readonly)
{
gfc_add_block_to_block (&parmse->post, &loop2.pre);
gfc_add_block_to_block (&parmse->post, &loop2.post);
diff --git a/gcc/testsuite/gfortran.dg/pr81978.f90
b/gcc/testsuite/gfortran.dg/pr81978.f90
new file mode 100644
index 000000000000..b377eef7a16c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pr81978.f90
@@ -0,0 +1,107 @@
+! { dg-do run }
+! PR fortran/81978 - do not copy back for parameter actual arguments
+
+module test_mod
+ implicit none
+
+ type pp_struct
+ character(10) :: name
+ real :: value
+ end type pp_struct
+
+ type(pp_struct), parameter :: pp(4) = [ &
+ pp_struct('one', 1.), &
+ pp_struct('two', 2.), &
+ pp_struct('three', 3.), &
+ pp_struct('four', 4.) ]
+
+contains
+
+ subroutine match_word (names)
+ character(*) :: names(:)
+ end subroutine match_word
+
+ subroutine sub0 (a)
+ real :: a(:)
+ end
+
+ subroutine sub1 (a, n)
+ integer, intent(in) :: n
+ real :: a(n)
+ end
+
+ subroutine subx (a)
+ real :: a(..)
+ end
+end module
+
+program test
+ use test_mod
+ implicit none
+ integer :: i, n
+ integer, parameter :: m = 8
+ real, parameter :: x(m) = [(i,i=1,m)]
+
+ n = size (x)
+ call sub0 (x)
+ call sub1 (x, n)
+ call sub2 (x, n)
+ call subx (x)
+
+ i = 1
+ call sub0 (x(1::i))
+ call sub1 (x(1::i), n)
+ call sub2 (x(1::i), n)
+ call subx (x(1::i))
+
+ n = size (x(1::2))
+ call sub0 (x(1::2))
+ call sub1 (x(1::2), n)
+ call sub2 (x(1::2), n)
+ call subx (x(1::2))
+
+ i = 2
+ call sub0 (x(1::i))
+ call sub1 (x(1::i), n)
+ call sub2 (x(1::i), n)
+ call subx (x(1::i))
+
+ call match_word (pp%name)
+ call sub0 (pp%value)
+ call subx (pp%value)
+ call match_word (pp(1::2)%name)
+ call sub0 (pp(1::2)%value)
+ call subx (pp(1::2)%value)
+ i = 1
+ call match_word (pp(1::i)%name)
+ call sub0 (pp(1::i)%value)
+ call subx (pp(1::i)%value)
+ i = 2
+ call match_word (pp(1::i)%name)
+ call sub0 (pp(1::i)%value)
+ call subx (pp(1::i)%value)
+
+ call foo (pp%name, size(pp%name))
+ call foo (pp(1::2)%name, size(pp(1::2)%name))
+ call sub1 (pp(1::2)%value, size(pp(1::2)%value))
+ call sub2 (pp(1::2)%value, size(pp(1::2)%value))
+ i = 1
+ call foo (pp(1::i)%name, size(pp(1::i)%name))
+ call sub1 (pp(1::i)%value, size(pp(1::i)%value))
+ call sub2 (pp(1::i)%value, size(pp(1::i)%value))
+ i = 2
+ call foo (pp(1::i)%name, size(pp(1::i)%name))
+ call sub1 (pp(1::i)%value, size(pp(1::i)%value))
+ call sub2 (pp(1::i)%value, size(pp(1::i)%value))
+end program
+
+subroutine sub2 (a, n)
+ integer, intent(in) :: n
+ real :: a(n)
+end
+
+subroutine foo (s, n)
+ integer, intent(in) :: n
+ character(*) :: s(*)
+! print *, len(s), n, s(n)
+end
