https://gcc.gnu.org/g:54e60dc0d4959bf51b24ac1dc9dfcf104876820b
commit 54e60dc0d4959bf51b24ac1dc9dfcf104876820b
Author: Mikael Morin <mik...@gcc.gnu.org>
Date: Fri Nov 17 19:04:19 2023 +0100
fortran: Inline unmasked integral MINLOC/MAXLOC with DIM [PR90608]
Enable generation of inline code for the MINLOC and MAXLOC intrinsics,
if the ARRAY argument is of integral type and of any rank (only the rank 1
case was previously inlined), the DIM argument is a constant value and there
is no MASK argument.
The restriction to integral ARRAY and absent MASK limits the scope of
the change to the cases where we generate single loop inline code.
This change uses the existing scalarizer suport for reductions, that is
arrays used in scalarization loops, where each element uses a nested
scalarization loop to calculate its value. The nested loop (and
respictively the nested scalarization chain) is created while walking the
MINLOC/MAXLOC expression, it's setup automatically by the outer scalarizer,
and gfc_conv_intrinsic_minmaxloc is changed to use it as a replacement for
the local loop variable (respectively ARRAY scalarization chain) used in the
non-reduction case (i.e. when DIM is absent).
PR fortran/90608
gcc/fortran/ChangeLog:
* trans-intrinsic.cc (gfc_inline_intrinsic_function_p): Return true
if DIM is constant, ARRAY is integral and MASK is absent.
(walk_inline_intrinsic_minmaxloc): If DIM is present, walk ARRAY and
move the dimension corresponding to DIM to a nested chain, keeping
the rest of the dimensions as the returned scalarization chain.
(gfc_conv_intrinsic_minmaxloc): When inside the scalarization loops,
proceed with inline code generation If DIM is present. If DIM is
present, skip result array creation and final initialization from
individual result local variables. If DIM is present and ARRAY has
rank greater than 1, use the nested loop initialized by the
scalarizer instead of the local one, use 1 as scalarization
dimension, and evaluate ARRAY using the inherited scalarization
chain instead of creating a local one by walking the expression.
gcc/testsuite/ChangeLog:
* gfortran.dg/maxloc_bounds_1.f90: Also accept the error message
generated by the scalarizer in case the function call is implemented
through inline code.
* gfortran.dg/maxloc_bounds_2.f90: Likewise.
* gfortran.dg/maxloc_bounds_3.f90: Likewise.
* gfortran.dg/minmaxloc_19.f90: New test.
Diff:
---
gcc/fortran/trans-intrinsic.cc | 227 ++++++++++++++++++--------
gcc/testsuite/gfortran.dg/maxloc_bounds_1.f90 | 4 +-
gcc/testsuite/gfortran.dg/maxloc_bounds_2.f90 | 4 +-
gcc/testsuite/gfortran.dg/maxloc_bounds_3.f90 | 4 +-
gcc/testsuite/gfortran.dg/minmaxloc_19.f90 | 182 +++++++++++++++++++++
5 files changed, 343 insertions(+), 78 deletions(-)
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index a282ae1c0903..dedb49b4a64e 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -5472,12 +5472,14 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr *
expr, enum tree_code op)
tree lab1, lab2;
tree b_if, b_else;
tree back;
- gfc_loopinfo loop;
- gfc_actual_arglist *actual;
- gfc_ss *arrayss;
- gfc_ss *maskss;
+ gfc_loopinfo loop, *ploop;
+ gfc_actual_arglist *actual, *array_arg, *dim_arg, *mask_arg, *kind_arg;
+ gfc_actual_arglist *back_arg;
+ gfc_ss *arrayss = nullptr;
+ gfc_ss *maskss = nullptr;
gfc_se arrayse;
gfc_se maskse;
+ gfc_se *base_se;
gfc_expr *arrayexpr;
gfc_expr *maskexpr;
gfc_expr *backexpr;
@@ -5489,6 +5491,14 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr *
expr, enum tree_code op)
bool optional_mask;
actual = expr->value.function.actual;
+ array_arg = actual;
+ dim_arg = array_arg->next;
+ mask_arg = dim_arg->next;
+ kind_arg = mask_arg->next;
+ back_arg = kind_arg->next;
+
+ bool dim_present = dim_arg->expr != nullptr;
+ bool nested_loop = dim_present && expr->rank > 0;
/* The last argument, BACK, is passed by value. Ensure that
by setting its name to %VAL. */
@@ -5502,11 +5512,15 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr *
expr, enum tree_code op)
{
if (se->ss->info->useflags)
{
- /* The inline implementation of MINLOC/MAXLOC has been generated
- before, out of the scalarization loop; now we can just use the
- result. */
- gfc_conv_tmp_array_ref (se);
- return;
+ if (!dim_present || !gfc_inline_intrinsic_function_p (expr))
+ {
+ /* The code generating and initializing the result array has been
+ generated already before the scalarization loop, either with a
+ library function call or with inline code; now we can just use
+ the result. */
+ gfc_conv_tmp_array_ref (se);
+ return;
+ }
}
else if (!gfc_inline_intrinsic_function_p (expr))
{
@@ -5522,8 +5536,9 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr *
expr, enum tree_code op)
if (arrayexpr->ts.type == BT_CHARACTER)
{
- gfc_actual_arglist *a;
- a = actual;
+ gcc_assert (expr->rank == 0);
+
+ gfc_actual_arglist *a = actual;
strip_kind_from_actual (a);
while (a)
{
@@ -5540,7 +5555,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr *
expr, enum tree_code op)
type = gfc_typenode_for_spec (&expr->ts);
- if (expr->rank > 0)
+ if (expr->rank > 0 && !dim_present)
{
gfc_array_spec as;
memset (&as, 0, sizeof (as));
@@ -5558,8 +5573,10 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr *
expr, enum tree_code op)
result_var = gfc_create_var (array, "loc_result");
}
+ const int reduction_dimensions = dim_present ? 1 : arrayexpr->rank;
+
/* Initialize the result. */
- for (int i = 0; i < arrayexpr->rank; i++)
+ for (int i = 0; i < reduction_dimensions; i++)
{
pos[i] = gfc_create_var (gfc_array_index_type,
gfc_get_string ("pos%d", i));
@@ -5569,17 +5586,11 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr *
expr, enum tree_code op)
gfc_get_string ("idx%d", i));
}
- /* Walk the arguments. */
- arrayss = gfc_walk_expr (arrayexpr);
- gcc_assert (arrayss != gfc_ss_terminator);
-
- actual = actual->next->next;
- gcc_assert (actual);
- maskexpr = actual->expr;
+ maskexpr = mask_arg->expr;
optional_mask = maskexpr && maskexpr->expr_type == EXPR_VARIABLE
&& maskexpr->symtree->n.sym->attr.dummy
&& maskexpr->symtree->n.sym->attr.optional;
- backexpr = actual->next->next->expr;
+ backexpr = back_arg->expr;
gfc_init_se (&backse, NULL);
if (backexpr == nullptr)
@@ -5604,13 +5615,25 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr *
expr, enum tree_code op)
back = gfc_evaluate_now_loc (input_location, back, &se->pre);
gfc_add_block_to_block (&se->pre, &backse.post);
- nonempty = NULL;
- if (maskexpr && maskexpr->rank != 0)
+ if (nested_loop)
+ base_se = se;
+ else
{
- maskss = gfc_walk_expr (maskexpr);
- gcc_assert (maskss != gfc_ss_terminator);
+ /* Walk the arguments. */
+ arrayss = gfc_walk_expr (arrayexpr);
+ gcc_assert (arrayss != gfc_ss_terminator);
+
+ if (maskexpr && maskexpr->rank != 0)
+ {
+ maskss = gfc_walk_expr (maskexpr);
+ gcc_assert (maskss != gfc_ss_terminator);
+ }
+
+ base_se = nullptr;
}
- else
+
+ nonempty = nullptr;
+ if (!(maskexpr && maskexpr->rank > 0))
{
mpz_t asize;
if (gfc_array_size (arrayexpr, &asize))
@@ -5681,47 +5704,59 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr *
expr, enum tree_code op)
"second_loop_entry");
gfc_add_modify (&se->pre, second_loop_entry, logical_false_node);
- /* Initialize the scalarizer. */
- gfc_init_loopinfo (&loop);
+ if (nested_loop)
+ {
+ ploop = enter_nested_loop (se);
+ ploop->temp_dim = 1;
+ }
+ else
+ {
+ /* Initialize the scalarizer. */
+ gfc_init_loopinfo (&loop);
- /* We add the mask first because the number of iterations is taken
- from the last ss, and this breaks if an absent optional argument
- is used for mask. */
+ /* We add the mask first because the number of iterations is taken
+ from the last ss, and this breaks if an absent optional argument
+ is used for mask. */
- if (maskss)
- gfc_add_ss_to_loop (&loop, maskss);
+ if (maskss)
+ gfc_add_ss_to_loop (&loop, maskss);
- gfc_add_ss_to_loop (&loop, arrayss);
+ gfc_add_ss_to_loop (&loop, arrayss);
- /* Initialize the loop. */
- gfc_conv_ss_startstride (&loop);
+ /* Initialize the loop. */
+ gfc_conv_ss_startstride (&loop);
- /* The code generated can have more than one loop in sequence (see the
- comment at the function header). This doesn't work well with the
- scalarizer, which changes arrays' offset when the scalarization loops
- are generated (see gfc_trans_preloop_setup). Fortunately, we can use
- the scalarizer temporary code to handle multiple loops. Thus, we set
- temp_dim here, we call gfc_mark_ss_chain_used with flag=3 later, and
- we use gfc_trans_scalarized_loop_boundary even later to restore
- offset. */
- loop.temp_dim = loop.dimen;
- gfc_conv_loop_setup (&loop, &expr->where);
+ /* The code generated can have more than one loop in sequence (see the
+ comment at the function header). This doesn't work well with the
+ scalarizer, which changes arrays' offset when the scalarization loops
+ are generated (see gfc_trans_preloop_setup). Fortunately, we can use
+ the scalarizer temporary code to handle multiple loops. Thus, we set
+ temp_dim here, we call gfc_mark_ss_chain_used with flag=3 later, and
+ we use gfc_trans_scalarized_loop_boundary even later to restore
+ offset. */
+ loop.temp_dim = loop.dimen;
+ gfc_conv_loop_setup (&loop, &expr->where);
+
+ ploop = &loop;
+ }
+
+ gcc_assert (reduction_dimensions == ploop->dimen);
if (nonempty == NULL && maskss == NULL)
{
nonempty = logical_true_node;
- for (int i = 0; i < loop.dimen; i++)
+ for (int i = 0; i < ploop->dimen; i++)
{
- if (!(loop.from[i] && loop.to[i]))
+ if (!(ploop->from[i] && ploop->to[i]))
{
nonempty = NULL;
break;
}
tree tmp = fold_build2_loc (input_location, LE_EXPR,
- logical_type_node, loop.from[i],
- loop.to[i]);
+ logical_type_node, ploop->from[i],
+ ploop->to[i]);
nonempty = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
logical_type_node, nonempty, tmp);
@@ -5741,11 +5776,12 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr *
expr, enum tree_code op)
gfc_array_index_type, nonempty,
gfc_index_one_node,
gfc_index_zero_node);
- for (int i = 0; i < loop.dimen; i++)
- gfc_add_modify (&loop.pre, pos[i], init);
+ for (int i = 0; i < ploop->dimen; i++)
+ gfc_add_modify (&ploop->pre, pos[i], init);
}
else
{
+ gcc_assert (!nested_loop);
for (int i = 0; i < loop.dimen; i++)
gfc_add_modify (&loop.pre, pos[i], gfc_index_zero_node);
lab1 = gfc_build_label_decl (NULL_TREE);
@@ -5756,24 +5792,29 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr *
expr, enum tree_code op)
/* An offset must be added to the loop
counter to obtain the required position. */
- for (int i = 0; i < loop.dimen; i++)
+ for (int i = 0; i < ploop->dimen; i++)
{
- gcc_assert (loop.from[i]);
+ gcc_assert (ploop->from[i]);
tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
- gfc_index_one_node, loop.from[i]);
- gfc_add_modify (&loop.pre, offset[i], tmp);
+ gfc_index_one_node, ploop->from[i]);
+ gfc_add_modify (&ploop->pre, offset[i], tmp);
+ }
+
+ if (!nested_loop)
+ {
+ gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1);
+ if (maskss)
+ gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1);
}
- gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1);
- if (maskss)
- gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1);
/* Generate the loop body. */
- gfc_start_scalarized_body (&loop, &body);
+ gfc_start_scalarized_body (ploop, &body);
/* If we have a mask, only check this element if the mask is set. */
if (maskss)
{
+ gcc_assert (!nested_loop);
gfc_init_se (&maskse, NULL);
gfc_copy_loopinfo_to_se (&maskse, &loop);
maskse.ss = maskss;
@@ -5786,9 +5827,10 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr *
expr, enum tree_code op)
gfc_init_block (&block);
/* Compare with the current limit. */
- gfc_init_se (&arrayse, NULL);
- gfc_copy_loopinfo_to_se (&arrayse, &loop);
- arrayse.ss = arrayss;
+ gfc_init_se (&arrayse, base_se);
+ gfc_copy_loopinfo_to_se (&arrayse, ploop);
+ if (!nested_loop)
+ arrayse.ss = arrayss;
gfc_conv_expr_val (&arrayse, arrayexpr);
gfc_add_block_to_block (&block, &arrayse.pre);
@@ -5803,6 +5845,8 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr *
expr, enum tree_code op)
stmtblock_t ifblock2;
tree ifbody2;
+ gcc_assert (!nested_loop);
+
gfc_start_block (&ifblock2);
for (int i = 0; i < loop.dimen; i++)
{
@@ -5819,12 +5863,12 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr *
expr, enum tree_code op)
gfc_add_expr_to_block (&block, tmp);
}
- for (int i = 0; i < loop.dimen; i++)
+ for (int i = 0; i < ploop->dimen; i++)
{
tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos[i]),
- loop.loopvar[i], offset[i]);
+ ploop->loopvar[i], offset[i]);
gfc_add_modify (&ifblock, pos[i], tmp);
- gfc_add_modify (&ifblock, idx[i], loop.loopvar[i]);
+ gfc_add_modify (&ifblock, idx[i], ploop->loopvar[i]);
}
gfc_add_modify (&ifblock, second_loop_entry, logical_true_node);
@@ -5891,6 +5935,8 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr *
expr, enum tree_code op)
if (lab1)
{
+ gcc_assert (!nested_loop);
+
for (int i = 0; i < loop.dimen; i++)
loop.from[i] = fold_build3_loc (input_location, COND_EXPR,
TREE_TYPE (loop.from[i]),
@@ -6007,7 +6053,7 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr *
expr, enum tree_code op)
gfc_add_modify (&body, second_loop_entry, logical_false_node);
}
- gfc_trans_scalarizing_loops (&loop, &body);
+ gfc_trans_scalarizing_loops (ploop, &body);
if (lab2)
gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
@@ -6017,6 +6063,8 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr *
expr, enum tree_code op)
{
tree ifmask;
+ gcc_assert (!nested_loop);
+
gfc_init_se (&maskse, NULL);
gfc_conv_expr_val (&maskse, maskexpr);
gfc_add_block_to_block (&se->pre, &maskse.pre);
@@ -6039,12 +6087,14 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr *
expr, enum tree_code op)
}
else
{
- gfc_add_block_to_block (&se->pre, &loop.pre);
- gfc_add_block_to_block (&se->pre, &loop.post);
+ gfc_add_block_to_block (&se->pre, &ploop->pre);
+ gfc_add_block_to_block (&se->pre, &ploop->post);
}
- gfc_cleanup_loop (&loop);
- if (expr->rank > 0)
+ if (!nested_loop)
+ gfc_cleanup_loop (&loop);
+
+ if (!dim_present)
{
for (int i = 0; i < arrayexpr->rank; i++)
{
@@ -11805,7 +11855,29 @@ walk_inline_intrinsic_minmaxloc (gfc_ss *ss, gfc_expr
*expr ATTRIBUTE_UNUSED)
if (expr->rank == 0)
return ss;
- return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
+ gfc_actual_arglist *array_arg = expr->value.function.actual;
+ gfc_actual_arglist *dim_arg = array_arg->next;
+
+ gfc_expr *array = array_arg->expr;
+ gfc_expr *dim = dim_arg->expr;
+
+ if (dim == nullptr)
+ return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
+
+ gfc_ss *tmp_ss = gfc_ss_terminator;
+
+ gfc_ss *array_ss = gfc_walk_subexpr (tmp_ss, array);
+ gcc_assert (array_ss != tmp_ss);
+
+ tmp_ss = array_ss;
+
+ /* "Hide" the dimension on which we will sum in the first arg's scalarization
+ chain. */
+ int dim_val = mpz_get_si (dim->value.integer) - 1;
+ gfc_ss *tail = nest_loop_dimension (tmp_ss, dim_val);
+ tail->next = ss;
+
+ return array_ss;
}
@@ -11944,9 +12016,11 @@ gfc_inline_intrinsic_function_p (gfc_expr *expr)
gfc_actual_arglist *array_arg = expr->value.function.actual;
gfc_actual_arglist *dim_arg = array_arg->next;
+ gfc_actual_arglist *mask_arg = dim_arg->next;
gfc_expr *array = array_arg->expr;
gfc_expr *dim = dim_arg->expr;
+ gfc_expr *mask = mask_arg->expr;
if (!(array->ts.type == BT_INTEGER
|| array->ts.type == BT_REAL))
@@ -11958,6 +12032,15 @@ gfc_inline_intrinsic_function_p (gfc_expr *expr)
if (dim == nullptr)
return true;
+ if (dim->expr_type != EXPR_CONSTANT)
+ return false;
+
+ if (array->ts.type != BT_INTEGER)
+ return false;
+
+ if (mask == nullptr)
+ return true;
+
return false;
}
diff --git a/gcc/testsuite/gfortran.dg/maxloc_bounds_1.f90
b/gcc/testsuite/gfortran.dg/maxloc_bounds_1.f90
index a107db2017a4..992519fd4772 100644
--- a/gcc/testsuite/gfortran.dg/maxloc_bounds_1.f90
+++ b/gcc/testsuite/gfortran.dg/maxloc_bounds_1.f90
@@ -1,6 +1,6 @@
! { dg-do run }
! { dg-options "-fbounds-check" }
-! { dg-shouldfail "Incorrect extent in return value of MAXLOC intrinsic in
dimension 1: is 3, should be 2" }
+! { dg-shouldfail "Incorrect extent in return value of MAXLOC intrinsic in
dimension 1: is 3, should be 2|Array bound mismatch for dimension 1 of array
'res' .3/2." }
program main
integer(kind=4), allocatable :: f(:,:)
integer(kind=4) :: res(3)
@@ -10,5 +10,5 @@ program main
res = maxloc(f,dim=1)
write(line,fmt='(80I1)') res
end program main
-! { dg-output "Fortran runtime error: Incorrect extent in return value of
MAXLOC intrinsic in dimension 1: is 3, should be 2" }
+! { dg-output "Fortran runtime error: Incorrect extent in return value of
MAXLOC intrinsic in dimension 1: is 3, should be 2|Array bound mismatch for
dimension 1 of array 'res' .3/2." }
diff --git a/gcc/testsuite/gfortran.dg/maxloc_bounds_2.f90
b/gcc/testsuite/gfortran.dg/maxloc_bounds_2.f90
index 39af3cb9fded..c5adb62e1153 100644
--- a/gcc/testsuite/gfortran.dg/maxloc_bounds_2.f90
+++ b/gcc/testsuite/gfortran.dg/maxloc_bounds_2.f90
@@ -1,6 +1,6 @@
! { dg-do run }
! { dg-options "-fbounds-check" }
-! { dg-shouldfail "Incorrect extent in return value of MAXLOC intrinsic in
dimension 1: is 3, should be 2" }
+! { dg-shouldfail "Incorrect extent in return value of MAXLOC intrinsic in
dimension 1: is 3, should be 2|Array bound mismatch for dimension 1 of array
'res' .3/2." }
program main
integer(kind=4), allocatable :: f(:,:)
logical, allocatable :: m(:,:)
@@ -12,5 +12,5 @@ program main
res = maxloc(f,dim=1,mask=m)
write(line,fmt='(80I1)') res
end program main
-! { dg-output "Fortran runtime error: Incorrect extent in return value of
MAXLOC intrinsic in dimension 1: is 3, should be 2" }
+! { dg-output "Fortran runtime error: Incorrect extent in return value of
MAXLOC intrinsic in dimension 1: is 3, should be 2|Array bound mismatch for
dimension 1 of array 'res' .3/2." }
diff --git a/gcc/testsuite/gfortran.dg/maxloc_bounds_3.f90
b/gcc/testsuite/gfortran.dg/maxloc_bounds_3.f90
index 41df6a8d093e..1c3850516248 100644
--- a/gcc/testsuite/gfortran.dg/maxloc_bounds_3.f90
+++ b/gcc/testsuite/gfortran.dg/maxloc_bounds_3.f90
@@ -1,6 +1,6 @@
! { dg-do run }
! { dg-options "-fbounds-check" }
-! { dg-shouldfail "Incorrect extent in MASK argument of MAXLOC intrinsic in
dimension 2: is 3, should be 2" }
+! { dg-shouldfail "Incorrect extent in MASK argument of MAXLOC intrinsic in
dimension 2: is 3, should be 2|Array bound mismatch for dimension 2 of array
'f' .2/3." }
program main
integer(kind=4), allocatable :: f(:,:)
logical, allocatable :: m(:,:)
@@ -12,5 +12,5 @@ program main
res = maxloc(f,dim=1,mask=m)
write(line,fmt='(80I1)') res
end program main
-! { dg-output "Fortran runtime error: Incorrect extent in MASK argument of
MAXLOC intrinsic in dimension 2: is 3, should be 2" }
+! { dg-output "Fortran runtime error: Incorrect extent in MASK argument of
MAXLOC intrinsic in dimension 2: is 3, should be 2|Array bound mismatch for
dimension 2 of array 'f' .2/3." }
diff --git a/gcc/testsuite/gfortran.dg/minmaxloc_19.f90
b/gcc/testsuite/gfortran.dg/minmaxloc_19.f90
new file mode 100644
index 000000000000..1073e966c355
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/minmaxloc_19.f90
@@ -0,0 +1,182 @@
+! { dg-do compile }
+! { dg-additional-options "-O -fdump-tree-original" }
+! { dg-final { scan-tree-dump-not "gfortran_\[sm\]?minloc" "original" } }
+! { dg-final { scan-tree-dump-not "gfortran_\[sm\]?maxloc" "original" } }
+!
+! PR fortran/90608
+! Check that all MINLOC and MAXLOC calls are inlined with optimizations,
+! when ARRAY is of integral type, DIM is a constant, and MASK is absent.
+
+subroutine check_maxloc
+ implicit none
+ integer, parameter :: data60(*) = (/ 2, 5, 4, 6, 0, 9, 3, 5, 4, 4, &
+ 1, 7, 3, 2, 1, 2, 5, 4, 6, 0, &
+ 9, 3, 5, 4, 4, 1, 7, 3, 2, 1, &
+ 2, 5, 4, 6, 0, 9, 3, 5, 4, 4, &
+ 1, 7, 3, 2, 1, 2, 5, 4, 6, 0, &
+ 9, 3, 5, 4, 4, 1, 7, 3, 2, 1 /)
+ integer, parameter :: data1(*) = (/ 2, 3, 2, 3, &
+ 1, 2, 3, 2, &
+ 3, 1, 2, 3, &
+ 2, 3, 1, 2, &
+ 3, 2, 3, 1 /)
+ integer, parameter :: data2(*) = (/ 2, 1, 2, &
+ 3, 2, 3, &
+ 4, 3, 4, &
+ 2, 1, 2, &
+ 1, 2, 1 /)
+ integer, parameter :: data3(*) = (/ 5, 1, 5, &
+ 1, 2, 1, &
+ 2, 1, 2, &
+ 3, 2, 3 /)
+ call check_int_const_shape_rank_3
+ call check_int_const_shape_empty_4
+ call check_int_alloc_rank_3
+ call check_int_alloc_empty_4
+contains
+ subroutine check_int_const_shape_rank_3()
+ integer :: a(3,4,5)
+ integer, allocatable :: r(:,:)
+ a = reshape(data60, shape(a))
+ r = maxloc(a, dim=1)
+ if (any(shape(r) /= (/ 4, 5 /))) stop 11
+ if (any(r /= reshape(data1, (/ 4, 5 /)))) stop 12
+ r = maxloc(a, dim=2)
+ if (any(shape(r) /= (/ 3, 5 /))) stop 13
+ if (any(r /= reshape(data2, (/ 3, 5 /)))) stop 14
+ r = maxloc(a, dim=3)
+ if (any(shape(r) /= (/ 3, 4 /))) stop 15
+ if (any(r /= reshape(data3, (/ 3, 4 /)))) stop 16
+ end subroutine
+ subroutine check_int_const_shape_empty_4()
+ integer :: a(9,3,0,7)
+ integer, allocatable :: r(:,:,:)
+ a = reshape((/ integer:: /), shape(a))
+ r = maxloc(a, dim=1)
+ if (any(shape(r) /= (/ 3, 0, 7 /))) stop 21
+ r = maxloc(a, dim=2)
+ if (any(shape(r) /= (/ 9, 0, 7 /))) stop 22
+ r = maxloc(a, dim=3)
+ if (any(shape(r) /= (/ 9, 3, 7 /))) stop 23
+ if (any(r /= 0)) stop 24
+ r = maxloc(a, dim=4)
+ if (any(shape(r) /= (/ 9, 3, 0 /))) stop 25
+ end subroutine
+ subroutine check_int_alloc_rank_3()
+ integer, allocatable :: a(:,:,:)
+ integer, allocatable :: r(:,:)
+ allocate(a(3,4,5))
+ a(:,:,:) = reshape(data60, shape(a))
+ r = maxloc(a, dim=1)
+ if (any(shape(r) /= (/ 4, 5 /))) stop 31
+ if (any(r /= reshape(data1, (/ 4, 5 /)))) stop 32
+ r = maxloc(a, dim=2)
+ if (any(shape(r) /= (/ 3, 5 /))) stop 33
+ if (any(r /= reshape(data2, (/ 3, 5 /)))) stop 34
+ r = maxloc(a, dim=3)
+ if (any(shape(r) /= (/ 3, 4 /))) stop 35
+ if (any(r /= reshape(data3, (/ 3, 4 /)))) stop 36
+ end subroutine
+ subroutine check_int_alloc_empty_4()
+ integer, allocatable :: a(:,:,:,:)
+ integer, allocatable :: r(:,:,:)
+ allocate(a(9,3,0,7))
+ a(:,:,:,:) = reshape((/ integer:: /), shape(a))
+ r = maxloc(a, dim=1)
+ if (any(shape(r) /= (/ 3, 0, 7 /))) stop 41
+ r = maxloc(a, dim=2)
+ if (any(shape(r) /= (/ 9, 0, 7 /))) stop 42
+ r = maxloc(a, dim=3)
+ if (any(shape(r) /= (/ 9, 3, 7 /))) stop 43
+ if (any(r /= 0)) stop 44
+ r = maxloc(a, dim=4)
+ if (any(shape(r) /= (/ 9, 3, 0 /))) stop 45
+ end subroutine
+end subroutine
+
+subroutine check_minloc
+ implicit none
+ integer, parameter :: data60(*) = (/ 7, 4, 5, 3, 9, 0, 6, 4, 5, 5, &
+ 8, 2, 6, 7, 8, 7, 4, 5, 3, 9, &
+ 0, 6, 4, 5, 5, 8, 2, 6, 7, 8, &
+ 7, 4, 5, 3, 9, 0, 6, 4, 5, 5, &
+ 8, 2, 6, 7, 8, 7, 4, 5, 3, 9, &
+ 0, 6, 4, 5, 5, 8, 2, 6, 7, 8 /)
+ integer, parameter :: data1(*) = (/ 2, 3, 2, 3, &
+ 1, 2, 3, 2, &
+ 3, 1, 2, 3, &
+ 2, 3, 1, 2, &
+ 3, 2, 3, 1 /)
+ integer, parameter :: data2(*) = (/ 2, 1, 2, &
+ 3, 2, 3, &
+ 4, 3, 4, &
+ 2, 1, 2, &
+ 1, 2, 1 /)
+ integer, parameter :: data3(*) = (/ 5, 1, 5, &
+ 1, 2, 1, &
+ 2, 1, 2, &
+ 3, 2, 3 /)
+ call check_int_const_shape_rank_3
+ call check_int_const_shape_empty_4
+ call check_int_alloc_rank_3
+ call check_int_alloc_empty_4
+contains
+ subroutine check_int_const_shape_rank_3()
+ integer :: a(3,4,5)
+ integer, allocatable :: r(:,:)
+ a = reshape(data60, shape(a))
+ r = minloc(a, dim=1)
+ if (any(shape(r) /= (/ 4, 5 /))) stop 11
+ if (any(r /= reshape(data1, (/ 4, 5 /)))) stop 12
+ r = minloc(a, dim=2)
+ if (any(shape(r) /= (/ 3, 5 /))) stop 13
+ if (any(r /= reshape(data2, (/ 3, 5 /)))) stop 14
+ r = minloc(a, dim=3)
+ if (any(shape(r) /= (/ 3, 4 /))) stop 15
+ if (any(r /= reshape(data3, (/ 3, 4 /)))) stop 16
+ end subroutine
+ subroutine check_int_const_shape_empty_4()
+ integer :: a(9,3,0,7)
+ integer, allocatable :: r(:,:,:)
+ a = reshape((/ integer:: /), shape(a))
+ r = minloc(a, dim=1)
+ if (any(shape(r) /= (/ 3, 0, 7 /))) stop 21
+ r = minloc(a, dim=2)
+ if (any(shape(r) /= (/ 9, 0, 7 /))) stop 22
+ r = minloc(a, dim=3)
+ if (any(shape(r) /= (/ 9, 3, 7 /))) stop 23
+ if (any(r /= 0)) stop 24
+ r = minloc(a, dim=4)
+ if (any(shape(r) /= (/ 9, 3, 0 /))) stop 25
+ end subroutine
+ subroutine check_int_alloc_rank_3()
+ integer, allocatable :: a(:,:,:)
+ integer, allocatable :: r(:,:)
+ allocate(a(3,4,5))
+ a(:,:,:) = reshape(data60, shape(a))
+ r = minloc(a, dim=1)
+ if (any(shape(r) /= (/ 4, 5 /))) stop 31
+ if (any(r /= reshape(data1, (/ 4, 5 /)))) stop 32
+ r = minloc(a, dim=2)
+ if (any(shape(r) /= (/ 3, 5 /))) stop 33
+ if (any(r /= reshape(data2, (/ 3, 5 /)))) stop 34
+ r = minloc(a, dim=3)
+ if (any(shape(r) /= (/ 3, 4 /))) stop 35
+ if (any(r /= reshape(data3, (/ 3, 4 /)))) stop 36
+ end subroutine
+ subroutine check_int_alloc_empty_4()
+ integer, allocatable :: a(:,:,:,:)
+ integer, allocatable :: r(:,:,:)
+ allocate(a(9,3,0,7))
+ a(:,:,:,:) = reshape((/ integer:: /), shape(a))
+ r = minloc(a, dim=1)
+ if (any(shape(r) /= (/ 3, 0, 7 /))) stop 41
+ r = minloc(a, dim=2)
+ if (any(shape(r) /= (/ 9, 0, 7 /))) stop 42
+ r = minloc(a, dim=3)
+ if (any(shape(r) /= (/ 9, 3, 7 /))) stop 43
+ if (any(r /= 0)) stop 44
+ r = minloc(a, dim=4)
+ if (any(shape(r) /= (/ 9, 3, 0 /))) stop 45
+ end subroutine
+end subroutine
