This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
[Patch, fortran] PR35743, PR34745, PR35759 and PR35756 - WHERE problems
- From: "Paul Richard Thomas" <paul dot richard dot thomas at gmail dot com>
- To: FX <fxcoudert at gmail dot com>
- Cc: "Dominique Dhumieres" <dominiq at lps dot ens dot fr>, "Fortran List" <fortran at gcc dot gnu dot org>, gcc-patches <gcc-patches at gcc dot gnu dot org>
- Date: Fri, 16 May 2008 22:07:01 +0200
- Subject: [Patch, fortran] PR35743, PR34745, PR35759 and PR35756 - WHERE problems
- Dkim-signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=gamma; h=domainkey-signature:received:received:message-id:date:from:to:subject:cc:mime-version:content-type; bh=QH5jHXlyxxnzDmzO4t6x5cmsvOmjB4YPRmdocwDRc80=; b=vK1zulKZOTlD9KLe4wBgdxyq5w1sSjKGXqEME4MsizyGd12VU3Q/PtewDw/bOCWy66DH2H/NKcECuPIvUKAndt3KtVh0mh7cLFKqt4YOyBAMqnt7HHT5EbgZuyQNdVXEdOIHkv45Bk9GuXkeFE3dM7CBmVxg6sd8YGtz3thOHYE=
- Domainkey-signature: a=rsa-sha1; c=nofws; d=gmail.com; s=gamma; h=message-id:date:from:to:subject:cc:mime-version:content-type; b=uxuiWPo0ETpggfZnaL0c9B0l146TAwXYGAkp+ZxlVDL9Q3GhIuTWXtmg6QKGmpJc0tjVhqf9NCeSMXLqTGP7DDq+1IaJ7L4pxhqwN4NZd6s113pRuCdJhONWICidAciftTaNxzKrLm3O7Z+s50RhYtLi8zTflNcgu9GLVMdTGOs=
FX,
>> 2008-05-15 Paul Thomas <pault@gcc.gnu.org>
>>
>> PR fortran/35756
>> PR fortran/35759
>> * trans-stmt.c (gfc_trans_where): Tighten up the dependency
>> check for calling gfc_trans_where_3.
>
> This is OK to commit.
In the course of preparing to commit this, I got diverted and fixed
PRs35743 and 5:)
Since both fixes are harmless and verging on obvious, I propose to
commit as soon as bootstrapping the updated tree and regtesting are
done.
Bootstrapped and regtested on x86_ia64/FC8.
Cheers and thanks
Paul
2008-05-16 Paul Thomas <pault@gcc.gnu.org>
PR fortran/35756
PR fortran/35759
* trans-stmt.c (gfc_trans_where): Tighten up the dependency
check for calling gfc_trans_where_3.
PR fortran/35743
* trans-stmt.c (gfc_trans_where_2): Set the mask size to zero
if it is calculated to be negative.
PR fortran/35745
* trans-stmt.c (gfc_trans_where_3, gfc_trans_where_assign): Set
ss->where for scalar right hand sides.
* trans-array.c (gfc_add_loop_ss_code): If ss->where is set do
not evaluate scalars outside the loop. Clean up whitespace.
* trans.h : Add a bitfield 'where' to gfc_ss.
2008-05-16 Paul Thomas <pault@gcc.gnu.org>
PR fortran/35756
PR fortran/35759
* gfortran.dg/where_1.f90: New test.
PR fortran/35743
PR fortran/35745
* gfortran.dg/where_2.f90: New test.
Index: gcc/fortran/trans-array.c
===================================================================
*** gcc/fortran/trans-array.c (revision 135438)
--- gcc/fortran/trans-array.c (working copy)
*************** gfc_add_loop_ss_code (gfc_loopinfo * loo
*** 1873,1892 ****
/* Scalar expression. Evaluate this now. This includes elemental
dimension indices, but not array section bounds. */
gfc_init_se (&se, NULL);
! gfc_conv_expr (&se, ss->expr);
! gfc_add_block_to_block (&loop->pre, &se.pre);
! if (ss->expr->ts.type != BT_CHARACTER)
! {
! /* Move the evaluation of scalar expressions outside the
! scalarization loop. */
! if (subscript)
! se.expr = convert(gfc_array_index_type, se.expr);
! se.expr = gfc_evaluate_now (se.expr, &loop->pre);
! gfc_add_block_to_block (&loop->pre, &se.post);
! }
! else
! gfc_add_block_to_block (&loop->post, &se.post);
ss->data.scalar.expr = se.expr;
ss->string_length = se.string_length;
--- 1873,1893 ----
/* Scalar expression. Evaluate this now. This includes elemental
dimension indices, but not array section bounds. */
gfc_init_se (&se, NULL);
! gfc_conv_expr (&se, ss->expr);
! gfc_add_block_to_block (&loop->pre, &se.pre);
! if (ss->expr->ts.type != BT_CHARACTER)
! {
! /* Move the evaluation of scalar expressions outside the
! scalarization loop, except for WHERE assignments. */
! if (subscript)
! se.expr = convert(gfc_array_index_type, se.expr);
! if (!ss->where)
! se.expr = gfc_evaluate_now (se.expr, &loop->pre);
! gfc_add_block_to_block (&loop->pre, &se.post);
! }
! else
! gfc_add_block_to_block (&loop->post, &se.post);
ss->data.scalar.expr = se.expr;
ss->string_length = se.string_length;
Index: gcc/fortran/trans-stmt.c
===================================================================
*** gcc/fortran/trans-stmt.c (revision 135438)
--- gcc/fortran/trans-stmt.c (working copy)
*************** gfc_trans_where_assign (gfc_expr *expr1,
*** 3150,3155 ****
--- 3150,3156 ----
{
/* The rhs is scalar. Add a ss for the expression. */
rss = gfc_get_ss ();
+ rss->where = 1;
rss->next = gfc_ss_terminator;
rss->type = GFC_SS_SCALAR;
rss->expr = expr2;
*************** gfc_trans_where_2 (gfc_code * code, tree
*** 3312,3317 ****
--- 3313,3319 ----
gfc_code *cblock;
gfc_code *cnext;
tree tmp;
+ tree cond;
tree count1, count2;
bool need_cmask;
bool need_pmask;
*************** gfc_trans_where_2 (gfc_code * code, tree
*** 3377,3382 ****
--- 3379,3391 ----
size = compute_overall_iter_number (nested_forall_info, inner_size,
&inner_size_body, block);
+ /* Check whether the size is negative. */
+ cond = fold_build2 (LE_EXPR, boolean_type_node, size,
+ gfc_index_zero_node);
+ size = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
+ gfc_index_zero_node, size);
+ size = gfc_evaluate_now (size, block);
+
/* Allocate temporary for WHERE mask if needed. */
if (need_cmask)
cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
*************** gfc_trans_where_3 (gfc_code * cblock, gf
*** 3578,3583 ****
--- 3587,3593 ----
if (tsss == gfc_ss_terminator)
{
tsss = gfc_get_ss ();
+ tsss->where = 1;
tsss->next = gfc_ss_terminator;
tsss->type = GFC_SS_SCALAR;
tsss->expr = tsrc;
*************** gfc_trans_where_3 (gfc_code * cblock, gf
*** 3595,3600 ****
--- 3605,3611 ----
if (esss == gfc_ss_terminator)
{
esss = gfc_get_ss ();
+ esss->where = 1;
esss->next = gfc_ss_terminator;
esss->type = GFC_SS_SCALAR;
esss->expr = esrc;
*************** gfc_trans_where (gfc_code * code)
*** 3709,3727 ****
block is dependence free if cond is not dependent on writes
to x1 and x2, y1 is not dependent on writes to x2, and y2
is not dependent on writes to x1, and both y's are not
! dependent upon their own x's. */
if (!gfc_check_dependency(cblock->next->expr,
cblock->expr, 0)
&& !gfc_check_dependency(eblock->next->expr,
cblock->expr, 0)
&& !gfc_check_dependency(cblock->next->expr,
! eblock->next->expr2, 0)
&& !gfc_check_dependency(eblock->next->expr,
! cblock->next->expr2, 0)
&& !gfc_check_dependency(cblock->next->expr,
! cblock->next->expr2, 0)
&& !gfc_check_dependency(eblock->next->expr,
! eblock->next->expr2, 0))
return gfc_trans_where_3 (cblock, eblock);
}
}
--- 3720,3747 ----
block is dependence free if cond is not dependent on writes
to x1 and x2, y1 is not dependent on writes to x2, and y2
is not dependent on writes to x1, and both y's are not
! dependent upon their own x's. In addition to this, the
! final two dependency checks below exclude all but the same
! array reference if the where and elswhere destinations
! are the same. In short, this is VERY conservative and this
! is needed because the two loops, required by the standard
! are coalesced in gfc_trans_where_3. */
if (!gfc_check_dependency(cblock->next->expr,
cblock->expr, 0)
&& !gfc_check_dependency(eblock->next->expr,
cblock->expr, 0)
&& !gfc_check_dependency(cblock->next->expr,
! eblock->next->expr2, 1)
! && !gfc_check_dependency(eblock->next->expr,
! cblock->next->expr2, 1)
! && !gfc_check_dependency(cblock->next->expr,
! cblock->next->expr2, 1)
&& !gfc_check_dependency(eblock->next->expr,
! eblock->next->expr2, 1)
&& !gfc_check_dependency(cblock->next->expr,
! eblock->next->expr, 0)
&& !gfc_check_dependency(eblock->next->expr,
! cblock->next->expr, 0))
return gfc_trans_where_3 (cblock, eblock);
}
}
Index: gcc/fortran/trans.h
===================================================================
*** gcc/fortran/trans.h (revision 135438)
--- gcc/fortran/trans.h (working copy)
*************** typedef struct gfc_ss
*** 201,208 ****
/* This is used by assignments requiring temporaries. The bits specify which
loops the terms appear in. This will be 1 for the RHS expressions,
! 2 for the LHS expressions, and 3(=1|2) for the temporary. */
! unsigned useflags:2;
}
gfc_ss;
#define gfc_get_ss() gfc_getmem(sizeof(gfc_ss))
--- 201,209 ----
/* This is used by assignments requiring temporaries. The bits specify which
loops the terms appear in. This will be 1 for the RHS expressions,
! 2 for the LHS expressions, and 3(=1|2) for the temporary. The bit
! 'where' suppresses precalculation of scalars in WHERE assignments. */
! unsigned useflags:2, where:1;
}
gfc_ss;
#define gfc_get_ss() gfc_getmem(sizeof(gfc_ss))
Index: gcc/testsuite/gfortran.dg/where_1.f90
===================================================================
*** gcc/testsuite/gfortran.dg/where_1.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/where_1.f90 (revision 0)
***************
*** 0 ****
--- 1,64 ----
+ ! { dg-do run }
+ ! Tests the fix for PR35759 and PR35756 in which the dependencies
+ ! led to an incorrect use of the "simple where", gfc_trans_where_3.
+ !
+ ! Contributed by Dick Hendrickson <dick.hendrickson@gmail.com>
+ !
+ logical :: la(6) = (/(2*(i/2) /= i, i = 1, 6)/), lb(6)
+ CALL PR35759
+ CALL PR35756
+ !
+ ! The first version of the fix caused this to regress as pointed
+ ! out by Dominique d'Humieres
+ !
+ lb = la
+ where(la)
+ la = .false.
+ elsewhere
+ la = .true.
+ end where
+ if (any(la .eqv. lb)) call abort()
+ CONTAINS
+ subroutine PR35759
+ integer UDA1L(6)
+ integer :: UDA1R(6), expected(6) = (/2,0,5,0,3,0/)
+ LOGICAL LDA(5)
+ UDA1L(1:6) = 0
+ uda1r = (/1,2,3,4,5,6/)
+ lda = (/ (i/2*2 .ne. I, i=1,5) /)
+ WHERE (LDA)
+ UDA1L(1:5) = UDA1R(2:6)
+ ELSEWHERE
+ UDA1L(2:6) = UDA1R(6:2:-1)
+ ENDWHERE
+ if (any (expected /= uda1l)) call abort
+ END subroutine
+
+ SUBROUTINE PR35756
+ INTEGER ILA(10), CLA(10)
+ LOGICAL LDA(10)
+ ILA = (/ (I, i=1,10) /)
+ LDA = (/ (i/2*2 .ne. I, i=1,10) /)
+ WHERE(LDA)
+ CLA = 10
+ ELSEWHERE
+ CLA = 2
+ ENDWHERE
+ WHERE(LDA)
+ ILA = R_MY_MAX_I(ILA)
+ ELSEWHERE
+ ILA = R_MY_MIN_I(ILA)
+ ENDWHERE
+ IF (any (CLA /= ILA)) call abort
+ end subroutine
+
+ INTEGER FUNCTION R_MY_MAX_I(A)
+ INTEGER :: A(:)
+ R_MY_MAX_I = MAXVAL(A)
+ END FUNCTION R_MY_MAX_I
+
+ INTEGER FUNCTION R_MY_MIN_I(A)
+ INTEGER :: A(:)
+ R_MY_MIN_I = MINVAL(A)
+ END FUNCTION R_MY_MIN_I
+ END
Index: gcc/testsuite/gfortran.dg/where_2.f90
===================================================================
*** gcc/testsuite/gfortran.dg/where_2.f90 (revision 0)
--- gcc/testsuite/gfortran.dg/where_2.f90 (revision 0)
***************
*** 0 ****
--- 1,36 ----
+ ! { dg-do run }
+ ! Tests the fix for PR35743 and PR35745.
+ !
+ ! Contributed by Dick Hendrickson <dick.hendrickson@gmail.com>
+ !
+ program try_rg0025
+ logical lda(5)
+ lda = (/(i/2*2 .ne. I, i=1,5)/)
+ call PR35743 (lda, 1, 2, 3, 5, 6, -1, -2)
+ CALL PR34745
+ end program
+
+ ! Previously, the negative mask size would not be detected.
+ SUBROUTINE PR35743 (LDA,nf1,nf2,nf3,nf5,nf6,mf1,mf2)
+ type unseq
+ real r
+ end type unseq
+ TYPE(UNSEQ) TDA1L(6)
+ LOGICAL LDA(NF5)
+ TDA1L(1:6)%r = 1.0
+ WHERE (LDA(NF6:NF3))
+ TDA1L(MF1:NF5:MF1) = TDA1L(NF6:NF2)
+ ENDWHERE
+ END SUBROUTINE
+
+ ! Previously, the expression in the WHERE block would be evaluated
+ ! ouside the loop generated by the where.
+ SUBROUTINE PR34745
+ INTEGER IDA(10)
+ REAL RDA(10)
+ RDA = 1.0
+ nf0 = 0
+ WHERE (RDA < -15.0)
+ IDA = 1/NF0 + 2
+ ENDWHERE
+ END SUBROUTINE