OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/61780 (Wrong code when shifting elements of a multidimensional array)

Browse Source 
2014-07-12  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/61780
	* dependency.c (gfc_dep_resolver): Index the 'reverse' array so
	that elements are skipped. This then correctly aligns 'reverse'
	with the scalarizer loops.

2014-07-12  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/61780
	* gfortran.dg/dependency_44.f90 : New test

From-SVN: r212486
This commit is contained in:
Paul Thomas 2014-07-12 19:09:11 +00:00
parent fae3018dcd
commit f8ec056116
4 changed files with 100 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
gcc/fortran/ChangeLog
View File

@ -1,3 +1,10 @@
2014-07-12 Paul Thomas <pault@gcc.gnu.org>
PR fortran/61780
* dependency.c (gfc_dep_resolver): Index the 'reverse' array so
that elements are skipped. This then correctly aligns 'reverse'
with the scalarizer loops.
2014-07-12 Tobias Burnus <burnus@net-b.de> 2014-07-12 Tobias Burnus <burnus@net-b.de>
PR fortran/61628 PR fortran/61628

95
gcc/fortran/dependency.c
View File

@ -22,7 +22,7 @@ along with GCC; see the file COPYING3. If not see
/* There's probably quite a bit of duplication in this file. We currently /* There's probably quite a bit of duplication in this file. We currently
have different dependency checking functions for different types have different dependency checking functions for different types
if dependencies. Ideally these would probably be merged. */ if dependencies. Ideally these would probably be merged. */
#include "config.h" #include "config.h"
#include "system.h" #include "system.h"
#include "coretypes.h" #include "coretypes.h"
@ -178,14 +178,14 @@ are_identical_variables (gfc_expr *e1, gfc_expr *e2)
/* If both are NULL, the end length compares equal, because we /* If both are NULL, the end length compares equal, because we
are looking at the same variable. This can only happen for are looking at the same variable. This can only happen for
assumed- or deferred-length character arguments. */ assumed- or deferred-length character arguments. */
if (r1->u.ss.end == NULL && r2->u.ss.end == NULL) if (r1->u.ss.end == NULL && r2->u.ss.end == NULL)
break; break;
if (gfc_dep_compare_expr (r1->u.ss.end, r2->u.ss.end) != 0) if (gfc_dep_compare_expr (r1->u.ss.end, r2->u.ss.end) != 0)
return false; return false;
break; break;
default: default:
@ -206,7 +206,7 @@ gfc_dep_compare_functions (gfc_expr *e1, gfc_expr *e2, bool impure_ok)
gfc_actual_arglist *args1; gfc_actual_arglist *args1;
gfc_actual_arglist *args2; gfc_actual_arglist *args2;
if (e1->expr_type != EXPR_FUNCTION || e2->expr_type != EXPR_FUNCTION) if (e1->expr_type != EXPR_FUNCTION || e2->expr_type != EXPR_FUNCTION)
return -2; return -2;
@ -226,18 +226,18 @@ gfc_dep_compare_functions (gfc_expr *e1, gfc_expr *e2, bool impure_ok)
/* Bitwise xor, since C has no non-bitwise xor operator. */ /* Bitwise xor, since C has no non-bitwise xor operator. */
if ((args1->expr == NULL) ^ (args2->expr == NULL)) if ((args1->expr == NULL) ^ (args2->expr == NULL))
return -2; return -2;
if (args1->expr != NULL && args2->expr != NULL if (args1->expr != NULL && args2->expr != NULL
&& gfc_dep_compare_expr (args1->expr, args2->expr) != 0) && gfc_dep_compare_expr (args1->expr, args2->expr) != 0)
return -2; return -2;
args1 = args1->next; args1 = args1->next;
args2 = args2->next; args2 = args2->next;
} }
return (args1 || args2) ? -2 : 0; return (args1 || args2) ? -2 : 0;
} }
else else
return -2; return -2;
} }
/* Helper function to look through parens, unary plus and widening /* Helper function to look through parens, unary plus and widening
@ -496,7 +496,7 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
/* Return the difference between two expressions. Integer expressions of /* Return the difference between two expressions. Integer expressions of
the form the form
X + constant, X - constant and constant + X X + constant, X - constant and constant + X
@ -687,7 +687,7 @@ gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result)
{ {
e2_op1 = discard_nops (e2->value.op.op1); e2_op1 = discard_nops (e2->value.op.op1);
e2_op2 = discard_nops (e2->value.op.op2); e2_op2 = discard_nops (e2->value.op.op2);
/* Case 14: (c1 - X) - (c2 - X) == c1 - c2. */ /* Case 14: (c1 - X) - (c2 - X) == c1 - c2. */
if (gfc_dep_compare_expr (e1_op2, e2_op2) == 0) if (gfc_dep_compare_expr (e1_op2, e2_op2) == 0)
{ {
@ -937,7 +937,7 @@ gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent,
switch (expr->expr_type) switch (expr->expr_type)
{ {
case EXPR_VARIABLE: case EXPR_VARIABLE:
/* In case of elemental subroutines, there is no dependency /* In case of elemental subroutines, there is no dependency
between two same-range array references. */ between two same-range array references. */
if (gfc_ref_needs_temporary_p (expr->ref) if (gfc_ref_needs_temporary_p (expr->ref)
|| gfc_check_dependency (var, expr, elemental == NOT_ELEMENTAL)) || gfc_check_dependency (var, expr, elemental == NOT_ELEMENTAL))
@ -947,24 +947,24 @@ gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent,
/* Too many false positive with pointers. */ /* Too many false positive with pointers. */
if (!gfc_is_data_pointer (var) && !gfc_is_data_pointer (expr)) if (!gfc_is_data_pointer (var) && !gfc_is_data_pointer (expr))
{ {
/* Elemental procedures forbid unspecified intents, /* Elemental procedures forbid unspecified intents,
and we don't check dependencies for INTENT_IN args. */ and we don't check dependencies for INTENT_IN args. */
gcc_assert (intent == INTENT_OUT || intent == INTENT_INOUT); gcc_assert (intent == INTENT_OUT || intent == INTENT_INOUT);
/* We are told not to check dependencies. /* We are told not to check dependencies.
We do it, however, and issue a warning in case we find one. We do it, however, and issue a warning in case we find one.
If a dependency is found in the case If a dependency is found in the case
elemental == ELEM_CHECK_VARIABLE, we will generate elemental == ELEM_CHECK_VARIABLE, we will generate
a temporary, so we don't need to bother the user. */ a temporary, so we don't need to bother the user. */
gfc_warning ("INTENT(%s) actual argument at %L might " gfc_warning ("INTENT(%s) actual argument at %L might "
"interfere with actual argument at %L.", "interfere with actual argument at %L.",
intent == INTENT_OUT ? "OUT" : "INOUT", intent == INTENT_OUT ? "OUT" : "INOUT",
&var->where, &expr->where); &var->where, &expr->where);
} }
return 0; return 0;
} }
else else
return 1; return 1;
} }
return 0; return 0;
@ -1010,17 +1010,17 @@ gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent,
dependencies, as we will make a temporary anyway. */ dependencies, as we will make a temporary anyway. */
if (elemental) if (elemental)
{ {
/* If the actual arg EXPR is an expression, we need to catch /* If the actual arg EXPR is an expression, we need to catch
a dependency between variables in EXPR and VAR, a dependency between variables in EXPR and VAR,
an intent((IN)OUT) variable. */ an intent((IN)OUT) variable. */
if (expr->value.op.op1 if (expr->value.op.op1
&& gfc_check_argument_var_dependency (var, intent, && gfc_check_argument_var_dependency (var, intent,
expr->value.op.op1, expr->value.op.op1,
ELEM_CHECK_VARIABLE)) ELEM_CHECK_VARIABLE))
return 1; return 1;
else if (expr->value.op.op2 else if (expr->value.op.op2
&& gfc_check_argument_var_dependency (var, intent, && gfc_check_argument_var_dependency (var, intent,
expr->value.op.op2, expr->value.op.op2,
ELEM_CHECK_VARIABLE)) ELEM_CHECK_VARIABLE))
return 1; return 1;
} }
@ -1030,8 +1030,8 @@ gfc_check_argument_var_dependency (gfc_expr *var, sym_intent intent,
return 0; return 0;
} }
} }
/* Like gfc_check_argument_var_dependency, but extended to any /* Like gfc_check_argument_var_dependency, but extended to any
array expression OTHER, not just variables. */ array expression OTHER, not just variables. */
@ -1154,7 +1154,7 @@ gfc_are_equivalenced_arrays (gfc_expr *e1, gfc_expr *e2)
/* Can these lengths be zero? */ /* Can these lengths be zero? */
if (fl1->length <= 0 || fl2->length <= 0) if (fl1->length <= 0 || fl2->length <= 0)
return 1; return 1;
/* These can't overlap if [f11,fl1+length] is before /* These can't overlap if [f11,fl1+length] is before
[fl2,fl2+length], or [fl2,fl2+length] is before [fl2,fl2+length], or [fl2,fl2+length] is before
[fl1,fl1+length], otherwise they do overlap. */ [fl1,fl1+length], otherwise they do overlap. */
if (fl1->offset + fl1->length > fl2->offset if (fl1->offset + fl1->length > fl2->offset
@ -1457,7 +1457,7 @@ check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n)
start_comparison = gfc_dep_compare_expr (l_start, r_start); start_comparison = gfc_dep_compare_expr (l_start, r_start);
else else
start_comparison = -2; start_comparison = -2;
gfc_free_expr (one_expr); gfc_free_expr (one_expr);
/* Determine LHS upper and lower bounds. */ /* Determine LHS upper and lower bounds. */
@ -1559,7 +1559,7 @@ check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n)
/* Check for forward dependencies x:y:-1 vs. x-1:z:-1 and /* Check for forward dependencies x:y:-1 vs. x-1:z:-1 and
x:y:-1 vs. x:y:-2. */ x:y:-1 vs. x:y:-2. */
if (l_dir == -1 && r_dir == -1 && if (l_dir == -1 && r_dir == -1 &&
(start_comparison == 0 || start_comparison == 1) (start_comparison == 0 || start_comparison == 1)
&& (stride_comparison == 0 || stride_comparison == 1)) && (stride_comparison == 0 || stride_comparison == 1))
return GFC_DEP_FORWARD; return GFC_DEP_FORWARD;
@ -1583,7 +1583,7 @@ check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n)
{ {
if (l_start && IS_ARRAY_EXPLICIT (l_ar->as)) if (l_start && IS_ARRAY_EXPLICIT (l_ar->as))
{ {
/* Check for a(high:y:-s) vs. a(z:x:-s) or /* Check for a(high:y:-s) vs. a(z:x:-s) or
a(high:y:-s vs. a(z:x:-s-1) where a has a higher bound a(high:y:-s vs. a(z:x:-s-1) where a has a higher bound
of high, which is always at least a forward dependence. */ of high, which is always at least a forward dependence. */
@ -2023,6 +2023,7 @@ int
gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse) gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse)
{ {
int n; int n;
int m;
gfc_dependency fin_dep; gfc_dependency fin_dep;
gfc_dependency this_dep; gfc_dependency this_dep;
@ -2045,12 +2046,12 @@ gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse)
if (lref->u.c.component != rref->u.c.component) if (lref->u.c.component != rref->u.c.component)
return 0; return 0;
break; break;
case REF_SUBSTRING: case REF_SUBSTRING:
/* Substring overlaps are handled by the string assignment code /* Substring overlaps are handled by the string assignment code
if there is not an underlying dependency. */ if there is not an underlying dependency. */
return (fin_dep == GFC_DEP_OVERLAP) ? 1 : 0; return (fin_dep == GFC_DEP_OVERLAP) ? 1 : 0;
case REF_ARRAY: case REF_ARRAY:
if (ref_same_as_full_array (lref, rref)) if (ref_same_as_full_array (lref, rref))
@ -2072,6 +2073,8 @@ gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse)
break; break;
} }
/* Index for the reverse array. */
m = -1;
for (n=0; n < lref->u.ar.dimen; n++) for (n=0; n < lref->u.ar.dimen; n++)
{ {
/* Handle dependency when either of array reference is vector /* Handle dependency when either of array reference is vector
@ -2081,7 +2084,7 @@ gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse)
if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
|| rref->u.ar.dimen_type[n] == DIMEN_VECTOR) || rref->u.ar.dimen_type[n] == DIMEN_VECTOR)
{ {
if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR if (lref->u.ar.dimen_type[n] == DIMEN_VECTOR
&& rref->u.ar.dimen_type[n] == DIMEN_VECTOR && rref->u.ar.dimen_type[n] == DIMEN_VECTOR
&& gfc_dep_compare_expr (lref->u.ar.start[n], && gfc_dep_compare_expr (lref->u.ar.start[n],
rref->u.ar.start[n]) == 0) rref->u.ar.start[n]) == 0)
@ -2101,7 +2104,7 @@ gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse)
else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT else if (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
&& lref->u.ar.dimen_type[n] == DIMEN_RANGE) && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
this_dep = gfc_check_element_vs_section (rref, lref, n); this_dep = gfc_check_element_vs_section (rref, lref, n);
else else
{ {
gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT gcc_assert (rref->u.ar.dimen_type[n] == DIMEN_ELEMENT
&& lref->u.ar.dimen_type[n] == DIMEN_ELEMENT); && lref->u.ar.dimen_type[n] == DIMEN_ELEMENT);
@ -2118,38 +2121,44 @@ gfc_dep_resolver (gfc_ref *lref, gfc_ref *rref, gfc_reverse *reverse)
The ability to reverse or not is set by previous conditions The ability to reverse or not is set by previous conditions
in this dimension. If reversal is not activated, the in this dimension. If reversal is not activated, the
value GFC_DEP_BACKWARD is reset to GFC_DEP_OVERLAP. */ value GFC_DEP_BACKWARD is reset to GFC_DEP_OVERLAP. */
/* Get the indexing right for the scalarizing loop. If this
is an element, there is no corresponding loop. */
if (lref->u.ar.dimen_type[n] != DIMEN_ELEMENT)
m++;
if (rref->u.ar.dimen_type[n] == DIMEN_RANGE if (rref->u.ar.dimen_type[n] == DIMEN_RANGE
&& lref->u.ar.dimen_type[n] == DIMEN_RANGE) && lref->u.ar.dimen_type[n] == DIMEN_RANGE)
{ {
/* Set reverse if backward dependence and not inhibited. */ /* Set reverse if backward dependence and not inhibited. */
if (reverse && reverse[n] == GFC_ENABLE_REVERSE) if (reverse && reverse[m] == GFC_ENABLE_REVERSE)
reverse[n] = (this_dep == GFC_DEP_BACKWARD) ? reverse[m] = (this_dep == GFC_DEP_BACKWARD) ?
GFC_REVERSE_SET : reverse[n]; GFC_REVERSE_SET : reverse[m];
/* Set forward if forward dependence and not inhibited. */ /* Set forward if forward dependence and not inhibited. */
if (reverse && reverse[n] == GFC_ENABLE_REVERSE) if (reverse && reverse[m] == GFC_ENABLE_REVERSE)
reverse[n] = (this_dep == GFC_DEP_FORWARD) ? reverse[m] = (this_dep == GFC_DEP_FORWARD) ?
GFC_FORWARD_SET : reverse[n]; GFC_FORWARD_SET : reverse[m];
/* Flag up overlap if dependence not compatible with /* Flag up overlap if dependence not compatible with
the overall state of the expression. */ the overall state of the expression. */
if (reverse && reverse[n] == GFC_REVERSE_SET if (reverse && reverse[m] == GFC_REVERSE_SET
&& this_dep == GFC_DEP_FORWARD) && this_dep == GFC_DEP_FORWARD)
{ {
reverse[n] = GFC_INHIBIT_REVERSE; reverse[m] = GFC_INHIBIT_REVERSE;
this_dep = GFC_DEP_OVERLAP; this_dep = GFC_DEP_OVERLAP;
} }
else if (reverse && reverse[n] == GFC_FORWARD_SET else if (reverse && reverse[m] == GFC_FORWARD_SET
&& this_dep == GFC_DEP_BACKWARD) && this_dep == GFC_DEP_BACKWARD)
{ {
reverse[n] = GFC_INHIBIT_REVERSE; reverse[m] = GFC_INHIBIT_REVERSE;
this_dep = GFC_DEP_OVERLAP; this_dep = GFC_DEP_OVERLAP;
} }
/* If no intention of reversing or reversing is explicitly /* If no intention of reversing or reversing is explicitly
inhibited, convert backward dependence to overlap. */ inhibited, convert backward dependence to overlap. */
if ((reverse == NULL && this_dep == GFC_DEP_BACKWARD) if ((reverse == NULL && this_dep == GFC_DEP_BACKWARD)
|| (reverse != NULL && reverse[n] == GFC_INHIBIT_REVERSE)) || (reverse != NULL && reverse[m] == GFC_INHIBIT_REVERSE))
this_dep = GFC_DEP_OVERLAP; this_dep = GFC_DEP_OVERLAP;
} }

5
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,8 @@
2014-07-12 Paul Thomas <pault@gcc.gnu.org>
PR fortran/61780
* gfortran.dg/dependency_44.f90 : New test
2014-07-12 Tobias Burnus <burnus@net-b.de> 2014-07-12 Tobias Burnus <burnus@net-b.de>
* gfortran.dg/coarray_atomic_1.f90: Update dg-error. * gfortran.dg/coarray_atomic_1.f90: Update dg-error.

36
gcc/testsuite/gfortran.dg/dependency_44.f90 Normal file
View File

@ -0,0 +1,36 @@
! { dg-do run }
! Tests fix for PR61780 in which the loop reversal mechanism was
! not accounting for the first index being an element so that no
! loop in this dimension is created.
!
! Contributed by Manfred Tietze on clf.
!
program prgm3
implicit none
integer, parameter :: n = 10, k = 3
integer :: i, j
integer, dimension(n,n) :: y
integer :: res1(n), res2(n)
1 format(10i5)
!initialize
do i=1,n
do j=1,n
y(i,j) = n*i + j
end do
end do
res2 = y(k,:)
!shift right
y(k,4:n) = y(k,3:n-1)
y(k,3) = 0
res1 = y(k,:)
y(k,:) = res2
y(k,n:4:-1) = y(k,n-1:3:-1)
y(k,3) = 0
res2 = y(k,:)
! print *, res1
! print *, res2
if (any(res1 /= res2)) call abort ()
end program prgm3