------- Comment #15 from tkoenig at gcc dot gnu dot org 2007-04-19 21:03
-------
(In reply to comment #14)
> (In reply to comment #13)
> > The tree stuff is hard, btw. Still trying :-)
>
> Tree stuff? Do we generate inline code?
We generate inline code for rank 0 minval and minloc, i.e.
real :: a(3)
print *,minloc(a,dim=1)
Here's a partial patch for this case:
Index: gfortran.h
===================================================================
--- gfortran.h (revision 123958)
+++ gfortran.h (working copy)
@@ -1351,7 +1351,7 @@ extern gfc_logical_info gfc_logical_kind
typedef struct
{
- mpfr_t epsilon, huge, tiny, subnormal;
+ mpfr_t epsilon, huge, tiny, subnormal, infinity;
int kind, radix, digits, min_exponent, max_exponent;
int range, precision;
Index: arith.c
===================================================================
--- arith.c (revision 123958)
+++ arith.c (working copy)
@@ -247,6 +247,10 @@ gfc_arith_init_1 (void)
if (i == real_info->radix)
real_info->precision++;
+ /* Infinity. */
+ mpfr_init (real_info->infinity);
+ mpfr_set_inf (real_info->infinity, 1);
+
mpfr_clear (a);
mpfr_clear (b);
mpfr_clear (c);
@@ -277,6 +281,7 @@ gfc_arith_done_1 (void)
mpfr_clear (rp->huge);
mpfr_clear (rp->tiny);
mpfr_clear (rp->subnormal);
+ mpfr_clear (rp->infinity);
}
}
Index: trans-intrinsic.c
===================================================================
--- trans-intrinsic.c (revision 123958)
+++ trans-intrinsic.c (working copy)
@@ -1926,8 +1926,10 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * s
tree limit;
tree type;
tree tmp;
+ tree tmp2;
tree elsetmp;
tree ifbody;
+ tree execute_loop;
gfc_loopinfo loop;
gfc_actual_arglist *actual;
gfc_ss *arrayss;
@@ -1967,11 +1969,14 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * s
maskss = NULL;
limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
+ execute_loop = gfc_create_var (boolean_type_node, "execute_loop");
+
n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
switch (arrayexpr->ts.type)
{
case BT_REAL:
- tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
arrayexpr->ts.kind);+ tmp = gfc_conv_mpfr_to_tree
(gfc_real_kinds[n].infinity,
+ arrayexpr->ts.kind);
break;
case BT_INTEGER:
@@ -2007,14 +2012,18 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * s
gcc_assert (loop.dimen == 1);
- /* Initialize the position to zero, following Fortran 2003. We are free
- to do this because Fortran 95 allows the result of an entirely false
- mask to be processor dependent. */
- gfc_add_modify_expr (&loop.pre, pos, gfc_index_zero_node);
+ /* Initialize the position to one. */
+ gfc_add_modify_expr (&loop.pre, pos, gfc_index_one_node);
gfc_mark_ss_chain_used (arrayss, 1);
if (maskss)
gfc_mark_ss_chain_used (maskss, 1);
+
+ /* Check whether the loop is evaluated at all. */
+
+ tmp2 = fold_build2 (GE_EXPR, boolean_type_node, loop.to[0], loop.from[0]);
+ gfc_add_modify_expr (&se->pre, execute_loop, tmp2);
+
/* Generate the loop body. */
gfc_start_scalarized_body (&loop, &body);
@@ -2050,10 +2059,9 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * s
ifbody = gfc_finish_block (&ifblock);
- /* If it is a more extreme value or pos is still zero. */
- tmp = build2 (TRUTH_OR_EXPR, boolean_type_node,
- build2 (op, boolean_type_node, arrayse.expr, limit),
- build2 (EQ_EXPR, boolean_type_node, pos,
gfc_index_zero_node));
+ /* If it is a more extreme value. */
+ tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
+
tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
gfc_add_expr_to_block (&block, tmp);
@@ -2066,36 +2074,41 @@ gfc_conv_intrinsic_minmaxloc (gfc_se * s
}
else
tmp = gfc_finish_block (&block);
+
gfc_add_expr_to_block (&body, tmp);
gfc_trans_scalarizing_loops (&loop, &body);
- /* For a scalar mask, enclose the loop in an if statement. */
+ /* Enclose the loop in an if statement. We don't execute it if the
+ trip count would be zero, or if a scalar mask is false. */
+
if (maskexpr && maskss == NULL)
{
gfc_init_se (&maskse, NULL);
gfc_conv_expr_val (&maskse, maskexpr);
- gfc_init_block (&block);
- gfc_add_block_to_block (&block, &loop.pre);
- gfc_add_block_to_block (&block, &loop.post);
- tmp = gfc_finish_block (&block);
- /* For the else part of the scalar mask, just initialize
- the pos variable the same way as above. */
+ execute_loop = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
execute_loop,
+ maskse.expr);
+ }
+
+ gfc_init_block (&block);
+ gfc_add_block_to_block (&block, &loop.pre);
+ gfc_add_block_to_block (&block, &loop.post);
- gfc_init_block (&elseblock);
- gfc_add_modify_expr (&elseblock, pos, gfc_index_zero_node);
- elsetmp = gfc_finish_block (&elseblock);
+ tmp = gfc_finish_block (&block);
+
+ /* For the else part of the scalar mask, just initialize
+ the pos variable the same way as above. */
+
+ gfc_init_block (&elseblock);
+ gfc_add_modify_expr (&elseblock, pos, gfc_index_zero_node);
+ elsetmp = gfc_finish_block (&elseblock);
+
+ tmp = build3_v (COND_EXPR, execute_loop, tmp, elsetmp);
+ gfc_add_expr_to_block (&block, tmp);
+
+ gfc_add_block_to_block (&se->pre, &block);
- tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
- gfc_add_expr_to_block (&block, tmp);
- gfc_add_block_to_block (&se->pre, &block);
- }
- else
- {
- gfc_add_block_to_block (&se->pre, &loop.pre);
- gfc_add_block_to_block (&se->pre, &loop.post);
- }
gfc_cleanup_loop (&loop);
/* Return a value in the range 1..SIZE(array). */
The problem with this is that it doesn't handle the loop
do n=1, size(a)
if (mask(n)) then
real_minloc_mask(1) = n
exit
end if
end do
at all, and my attempts to generate it using the scalarizer
have ended in ICEs (so far).
--
http://gcc.gnu.org/bugzilla/show_bug.cgi?id=30694
