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;
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. */
{
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))
{
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)
{
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));
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));
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)
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))
"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);
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);
/* 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;
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);
stmtblock_t ifblock2;
tree ifbody2;
+ gcc_assert (!nested_loop);
+
gfc_start_block (&ifblock2);
for (int i = 0; i < loop.dimen; i++)
{
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);
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]),
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));
{
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);
}
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++)
{
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;
+
+ /* Move the dimension on which we will sum to a separate nested scalarization
+ chain, "hiding" that dimension from the outer scalarization. */
+ int dim_val = mpz_get_si (dim->value.integer);
+ gfc_ss *tail = nest_loop_dimension (tmp_ss, dim_val - 1);
+ tail->next = ss;
+
+ return array_ss;
}
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))
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;
}
--- /dev/null
+! { 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 /))) error stop 11
+ if (any(r /= reshape(data1, (/ 4, 5 /)))) error stop 12
+ r = maxloc(a, dim=2)
+ if (any(shape(r) /= (/ 3, 5 /))) error stop 13
+ if (any(r /= reshape(data2, (/ 3, 5 /)))) error stop 14
+ r = maxloc(a, dim=3)
+ if (any(shape(r) /= (/ 3, 4 /))) error stop 15
+ if (any(r /= reshape(data3, (/ 3, 4 /)))) error 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 /))) error stop 21
+ r = maxloc(a, dim=2)
+ if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 22
+ r = maxloc(a, dim=3)
+ if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 23
+ if (any(r /= 0)) error stop 24
+ r = maxloc(a, dim=4)
+ if (any(shape(r) /= (/ 9, 3, 0 /))) error 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 /))) error stop 31
+ if (any(r /= reshape(data1, (/ 4, 5 /)))) error stop 32
+ r = maxloc(a, dim=2)
+ if (any(shape(r) /= (/ 3, 5 /))) error stop 33
+ if (any(r /= reshape(data2, (/ 3, 5 /)))) error stop 34
+ r = maxloc(a, dim=3)
+ if (any(shape(r) /= (/ 3, 4 /))) error stop 35
+ if (any(r /= reshape(data3, (/ 3, 4 /)))) error 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 /))) error stop 41
+ r = maxloc(a, dim=2)
+ if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 42
+ r = maxloc(a, dim=3)
+ if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 43
+ if (any(r /= 0)) error stop 44
+ r = maxloc(a, dim=4)
+ if (any(shape(r) /= (/ 9, 3, 0 /))) error 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 /))) error stop 111
+ if (any(r /= reshape(data1, (/ 4, 5 /)))) error stop 112
+ r = minloc(a, dim=2)
+ if (any(shape(r) /= (/ 3, 5 /))) error stop 113
+ if (any(r /= reshape(data2, (/ 3, 5 /)))) error stop 114
+ r = minloc(a, dim=3)
+ if (any(shape(r) /= (/ 3, 4 /))) error stop 115
+ if (any(r /= reshape(data3, (/ 3, 4 /)))) error stop 116
+ 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 /))) error stop 121
+ r = minloc(a, dim=2)
+ if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 122
+ r = minloc(a, dim=3)
+ if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 123
+ if (any(r /= 0)) error stop 124
+ r = minloc(a, dim=4)
+ if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 125
+ 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 /))) error stop 131
+ if (any(r /= reshape(data1, (/ 4, 5 /)))) error stop 132
+ r = minloc(a, dim=2)
+ if (any(shape(r) /= (/ 3, 5 /))) error stop 133
+ if (any(r /= reshape(data2, (/ 3, 5 /)))) error stop 134
+ r = minloc(a, dim=3)
+ if (any(shape(r) /= (/ 3, 4 /))) error stop 135
+ if (any(r /= reshape(data3, (/ 3, 4 /)))) error stop 136
+ 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 /))) error stop 141
+ r = minloc(a, dim=2)
+ if (any(shape(r) /= (/ 9, 0, 7 /))) error stop 142
+ r = minloc(a, dim=3)
+ if (any(shape(r) /= (/ 9, 3, 7 /))) error stop 143
+ if (any(r /= 0)) error stop 144
+ r = minloc(a, dim=4)
+ if (any(shape(r) /= (/ 9, 3, 0 /))) error stop 145
+ end subroutine
+end subroutine
projects / thirdparty / gcc.git / commitdiff
