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 --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index afbec5b275222c110372317e73ebd1e3124a9991..51237d0d3be6fd8c3e9d53ad8b5d00665109d7d0 100644 (file)
--- 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 (file)
index 0000000..1c1a048
--- /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