Dear all,
while looking at details of a related but slightly different PR, I found
that we did evaluate the arguments to MINLOC/MAXLOC too often in the
inlined version.
The attached patch creates temporaries for array elements where needed,
and ensures that each array element is only touched once. This required
a minor adjustment for the rank-1 algorithm, which is documented.
Regtested on x86_64-pc-linux-gnu. OK for mainline?
Thanks,
Harald
From d2a52256b3e4817e16a5d222c2fecd7bc66e5613 Mon Sep 17 00:00:00 2001
From: Harald Anlauf <anl...@gmx.de>
Date: Wed, 22 Jan 2025 22:44:39 +0100
Subject: [PATCH] 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.
---
gcc/fortran/trans-intrinsic.cc | 37 +++++++-
.../gfortran.dg/maxval_arg_eval_count.f90 | 88 +++++++++++++++++++
2 files changed, 121 insertions(+), 4 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/maxval_arg_eval_count.f90
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index afbec5b2752..51237d0d3be 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 00000000000..1c1a04819a0
--- /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
--
2.43.0
