https://gcc.gnu.org/g:3cef53a4d4ff44a5b61284bb0e6977f7ba7b3aab
commit r15-7165-g3cef53a4d4ff44a5b61284bb0e6977f7ba7b3aab
Author: Harald Anlauf <anl...@gmx.de>
Date: Wed Jan 22 22:44:39 2025 +0100
Fortran: do not evaluate arguments of MAXVAL/MINVAL too often [PR118613]
PR fortran/118613
gcc/fortran/ChangeLog:
* trans-intrinsic.cc (gfc_conv_intrinsic_minmaxval): Adjust
algorithm
for inlined version of MINLOC and MAXLOC so that arguments are only
evaluted once, and create temporaries where necessary. Document
change of algorithm.
gcc/testsuite/ChangeLog:
* gfortran.dg/maxval_arg_eval_count.f90: New test.
Diff:
---
gcc/fortran/trans-intrinsic.cc | 37 ++++++++-
.../gfortran.dg/maxval_arg_eval_count.f90 | 88 ++++++++++++++++++++++
2 files changed, 121 insertions(+), 4 deletions(-)
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index afbec5b27522..51237d0d3be6 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -6409,8 +6409,16 @@ gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr)
nonempty = false;
S = from;
while (S <= to) {
- if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
- S++;
+ if (mask[S]) {
+ nonempty = true;
+ if (a[S] <= limit) {
+ limit = a[S];
+ S++;
+ goto lab;
+ }
+ else
+ S++;
+ }
}
limit = nonempty ? NaN : huge (limit);
lab:
@@ -6419,7 +6427,15 @@ gfc_conv_intrinsic_findloc (gfc_se *se, gfc_expr *expr)
at runtime whether array is nonempty or not, rank 1:
limit = Infinity;
S = from;
- while (S <= to) { if (a[S] <= limit) goto lab; S++; }
+ while (S <= to) {
+ if (a[S] <= limit) {
+ limit = a[S];
+ S++;
+ goto lab;
+ }
+ else
+ S++;
+ }
limit = (from <= to) ? NaN : huge (limit);
lab:
while (S <= to) { limit = min (a[S], limit); S++; }
@@ -6710,6 +6726,7 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr *
expr, enum tree_code op)
gfc_copy_loopinfo_to_se (&arrayse, &loop);
arrayse.ss = arrayss;
gfc_conv_expr_val (&arrayse, arrayexpr);
+ arrayse.expr = gfc_evaluate_now (arrayse.expr, &arrayse.pre);
gfc_add_block_to_block (&block, &arrayse.pre);
gfc_init_block (&block2);
@@ -6722,7 +6739,18 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr *
expr, enum tree_code op)
tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
logical_type_node, arrayse.expr, limit);
if (lab)
- ifbody = build1_v (GOTO_EXPR, lab);
+ {
+ stmtblock_t ifblock;
+ tree inc_loop;
+ inc_loop = fold_build2_loc (input_location, PLUS_EXPR,
+ TREE_TYPE (loop.loopvar[0]),
+ loop.loopvar[0], gfc_index_one_node);
+ gfc_init_block (&ifblock);
+ gfc_add_modify (&ifblock, limit, arrayse.expr);
+ gfc_add_modify (&ifblock, loop.loopvar[0], inc_loop);
+ gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab));
+ ifbody = gfc_finish_block (&ifblock);
+ }
else
{
stmtblock_t ifblock;
@@ -6816,6 +6844,7 @@ gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr *
expr, enum tree_code op)
gfc_copy_loopinfo_to_se (&arrayse, &loop);
arrayse.ss = arrayss;
gfc_conv_expr_val (&arrayse, arrayexpr);
+ arrayse.expr = gfc_evaluate_now (arrayse.expr, &arrayse.pre);
gfc_add_block_to_block (&block, &arrayse.pre);
/* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
diff --git a/gcc/testsuite/gfortran.dg/maxval_arg_eval_count.f90
b/gcc/testsuite/gfortran.dg/maxval_arg_eval_count.f90
new file mode 100644
index 000000000000..1c1a04819a0a
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/maxval_arg_eval_count.f90
@@ -0,0 +1,88 @@
+! { dg-do run }
+!
+! PR fortran/118613 - check argument evaluation count of MAXVAL
+
+program p
+ implicit none
+ integer, parameter :: k = 2
+ integer :: n
+ integer :: i1(k*k), i2(k,k), mm
+ real :: a1(k*k), a2(k,k), mx
+ complex :: c1(k*k), c2(k,k)
+ logical :: m1(k*k), m2(k,k)
+
+ ! prepare mask for masked variants
+ m1 = .true.
+ m2 = .true.
+ i1 = 0
+ i2 = 0
+ a1 = 0.
+ a2 = 0.
+ c1 = 0.
+ c2 = 0.
+
+ ! integer
+ n = 0
+ mm = maxval (h(i1))
+ if (n /= k*k .or. mm /= 0) stop 1
+ n = 0
+ mm = maxval (h(i2))
+ if (n /= k*k .or. mm /= 0) stop 2
+ n = 0
+ mm = maxval (h(i1),m1)
+ if (n /= k*k .or. mm /= 0) stop 3
+ n = 0
+ mm = maxval (h(i2),m2)
+ if (n /= k*k .or. mm /= 0) stop 4
+
+ ! real
+ n = 0
+ mx = maxval (f(a1))
+ if (n /= k*k .or. mx /= 0) stop 5
+ n = 0
+ mx = maxval (f(a2))
+ if (n /= k*k .or. mx /= 0) stop 6
+ n = 0
+ mx = maxval (f(a1),m1)
+ if (n /= k*k .or. mx /= 0) stop 7
+ n = 0
+ mx = maxval (f(a2),m2)
+ if (n /= k*k .or. mx /= 0) stop 8
+
+ ! complex
+ n = 0
+ mx = maxval (g(c1))
+ if (n /= k*k .or. mx /= 0) stop 9
+ n = 0
+ mx = maxval (g(c2))
+ if (n /= k*k .or. mx /= 0) stop 10
+ n = 0
+ mx = maxval (g(c1),m1)
+ if (n /= k*k .or. mx /= 0) stop 11
+ n = 0
+ mx = maxval (g(c2),m2)
+ if (n /= k*k .or. mx /= 0) stop 12
+
+contains
+
+ impure elemental function h (x)
+ integer, intent(in) :: x
+ integer :: h
+ h = abs (x)
+ n = n + 1 ! Count number of function evaluations
+ end
+
+ impure elemental function f (x)
+ real, intent(in) :: x
+ real :: f
+ f = abs (x)
+ n = n + 1 ! Count number of function evaluations
+ end
+
+ impure elemental function g (x)
+ complex, intent(in) :: x
+ real :: g
+ g = abs (x)
+ n = n + 1 ! Count number of function evaluations
+ end
+end
