diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 8c3a4d994bd..f1f176573c4 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,15 @@ +2013-03-28 Thomas Koenig + + PR fortran/45159 + * gfortran.h (gfc_dep_difference): Add prototype. + * dependency.c (discard_nops): New function. + (gfc_dep_difference): New function. + (check_section_vs_section): Use gfc_dep_difference + to calculate the difference of starting indices. + * trans-expr.c (gfc_conv_substring): Use + gfc_dep_difference to calculate the length of + substrings where possible. + 2013-03-28 Thomas Koenig PR fortran/55806 diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c index e58bd227bde..062b1c5837a 100644 --- a/gcc/fortran/dependency.c +++ b/gcc/fortran/dependency.c @@ -501,6 +501,272 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2) } +/* Helper function to look through parens and unary plus. */ + +static gfc_expr* +discard_nops (gfc_expr *e) +{ + + while (e && e->expr_type == EXPR_OP + && (e->value.op.op == INTRINSIC_UPLUS + || e->value.op.op == INTRINSIC_PARENTHESES)) + e = e->value.op.op1; + + return e; +} + + +/* Return the difference between two expressions. Integer expressions of + the form + + X + constant, X - constant and constant + X + + are handled. Return true on success, false on failure. result is assumed + to be uninitialized on entry, and will be initialized on success. +*/ + +bool +gfc_dep_difference (gfc_expr *e1, gfc_expr *e2, mpz_t *result) +{ + gfc_expr *e1_op1, *e1_op2, *e2_op1, *e2_op2; + + if (e1 == NULL || e2 == NULL) + return false; + + if (e1->ts.type != BT_INTEGER || e2->ts.type != BT_INTEGER) + return false; + + e1 = discard_nops (e1); + e2 = discard_nops (e2); + + /* Inizialize tentatively, clear if we don't return anything. */ + mpz_init (*result); + + /* Case 1: c1 - c2 = c1 - c2, trivially. */ + + if (e1->expr_type == EXPR_CONSTANT && e2->expr_type == EXPR_CONSTANT) + { + mpz_sub (*result, e1->value.integer, e2->value.integer); + return true; + } + + if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_PLUS) + { + e1_op1 = discard_nops (e1->value.op.op1); + e1_op2 = discard_nops (e1->value.op.op2); + + /* Case 2: (X + c1) - X = c1. */ + if (e1_op2->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op1, e2) == 0) + { + mpz_set (*result, e1_op2->value.integer); + return true; + } + + /* Case 3: (c1 + X) - X = c1. */ + if (e1_op1->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op2, e2) == 0) + { + mpz_set (*result, e1_op1->value.integer); + return true; + } + + if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS) + { + e2_op1 = discard_nops (e2->value.op.op1); + e2_op2 = discard_nops (e2->value.op.op2); + + if (e1_op2->expr_type == EXPR_CONSTANT) + { + /* Case 4: X + c1 - (X + c2) = c1 - c2. */ + if (e2_op2->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op1, e2_op1) == 0) + { + mpz_sub (*result, e1_op2->value.integer, + e2_op2->value.integer); + return true; + } + /* Case 5: X + c1 - (c2 + X) = c1 - c2. */ + if (e2_op1->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op1, e2_op2) == 0) + { + mpz_sub (*result, e1_op2->value.integer, + e2_op1->value.integer); + return true; + } + } + else if (e1_op1->expr_type == EXPR_CONSTANT) + { + /* Case 6: c1 + X - (X + c2) = c1 - c2. */ + if (e2_op2->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op2, e2_op1) == 0) + { + mpz_sub (*result, e1_op1->value.integer, + e2_op2->value.integer); + return true; + } + /* Case 7: c1 + X - (c2 + X) = c1 - c2. */ + if (e2_op1->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op2, e2_op2) == 0) + { + mpz_sub (*result, e1_op1->value.integer, + e2_op1->value.integer); + return true; + } + } + } + + if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) + { + e2_op1 = discard_nops (e2->value.op.op1); + e2_op2 = discard_nops (e2->value.op.op2); + + if (e1_op2->expr_type == EXPR_CONSTANT) + { + /* Case 8: X + c1 - (X - c2) = c1 + c2. */ + if (e2_op2->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op1, e2_op1) == 0) + { + mpz_add (*result, e1_op2->value.integer, + e2_op2->value.integer); + return true; + } + } + if (e1_op1->expr_type == EXPR_CONSTANT) + { + /* Case 9: c1 + X - (X - c2) = c1 + c2. */ + if (e2_op2->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op2, e2_op1) == 0) + { + mpz_add (*result, e1_op1->value.integer, + e2_op2->value.integer); + return true; + } + } + } + } + + if (e1->expr_type == EXPR_OP && e1->value.op.op == INTRINSIC_MINUS) + { + e1_op1 = discard_nops (e1->value.op.op1); + e1_op2 = discard_nops (e1->value.op.op2); + + if (e1_op2->expr_type == EXPR_CONSTANT) + { + /* Case 10: (X - c1) - X = -c1 */ + + if (gfc_dep_compare_expr (e1_op1, e2) == 0) + { + mpz_neg (*result, e1_op2->value.integer); + return true; + } + + if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS) + { + e2_op1 = discard_nops (e2->value.op.op1); + e2_op2 = discard_nops (e2->value.op.op2); + + /* Case 11: (X - c1) - (X + c2) = -( c1 + c2). */ + if (e2_op2->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op1, e2_op1) == 0) + { + mpz_add (*result, e1_op2->value.integer, + e2_op2->value.integer); + mpz_neg (*result, *result); + return true; + } + + /* Case 12: X - c1 - (c2 + X) = - (c1 + c2). */ + if (e2_op1->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op1, e2_op2) == 0) + { + mpz_add (*result, e1_op2->value.integer, + e2_op1->value.integer); + mpz_neg (*result, *result); + return true; + } + } + + if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) + { + e2_op1 = discard_nops (e2->value.op.op1); + e2_op2 = discard_nops (e2->value.op.op2); + + /* Case 13: (X - c1) - (X - c2) = c2 - c1. */ + if (e2_op2->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1_op1, e2_op1) == 0) + { + mpz_sub (*result, e2_op2->value.integer, + e1_op2->value.integer); + return true; + } + } + } + if (e1_op1->expr_type == EXPR_CONSTANT) + { + if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) + { + e2_op1 = discard_nops (e2->value.op.op1); + e2_op2 = discard_nops (e2->value.op.op2); + + /* Case 14: (c1 - X) - (c2 - X) == c1 - c2. */ + if (gfc_dep_compare_expr (e1_op2, e2_op2) == 0) + { + mpz_sub (*result, e1_op1->value.integer, + e2_op1->value.integer); + return true; + } + } + + } + } + + if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_PLUS) + { + e2_op1 = discard_nops (e2->value.op.op1); + e2_op2 = discard_nops (e2->value.op.op2); + + /* Case 15: X - (X + c2) = -c2. */ + if (e2_op2->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1, e2_op1) == 0) + { + mpz_neg (*result, e2_op2->value.integer); + return true; + } + /* Case 16: X - (c2 + X) = -c2. */ + if (e2_op1->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1, e2_op2) == 0) + { + mpz_neg (*result, e2_op1->value.integer); + return true; + } + } + + if (e2->expr_type == EXPR_OP && e2->value.op.op == INTRINSIC_MINUS) + { + e2_op1 = discard_nops (e2->value.op.op1); + e2_op2 = discard_nops (e2->value.op.op2); + + /* Case 17: X - (X - c2) = c2. */ + if (e2_op2->expr_type == EXPR_CONSTANT + && gfc_dep_compare_expr (e1, e2_op1) == 0) + { + mpz_set (*result, e2_op2->value.integer); + return true; + } + } + + if (gfc_dep_compare_expr(e1, e2) == 0) + { + /* Case 18: X - X = 0. */ + mpz_set_si (*result, 0); + return true; + } + + mpz_clear (*result); + return false; +} + /* Returns 1 if the two ranges are the same and 0 if they are not (or if the results are indeterminate). 'n' is the dimension to compare. */ @@ -1140,6 +1406,7 @@ check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n) int r_dir; int stride_comparison; int start_comparison; + mpz_t tmp; /* If they are the same range, return without more ado. */ if (is_same_range (l_ar, r_ar, n)) @@ -1275,24 +1542,20 @@ check_section_vs_section (gfc_array_ref *l_ar, gfc_array_ref *r_ar, int n) (l_start - r_start) / gcd(l_stride, r_stride) is nonzero. TODO: - - Handle cases where x is an expression. - Cases like a(1:4:2) = a(2:3) are still not handled. */ #define IS_CONSTANT_INTEGER(a) ((a) && ((a)->expr_type == EXPR_CONSTANT) \ && (a)->ts.type == BT_INTEGER) - if (IS_CONSTANT_INTEGER(l_start) && IS_CONSTANT_INTEGER(r_start) - && IS_CONSTANT_INTEGER(l_stride) && IS_CONSTANT_INTEGER(r_stride)) + if (IS_CONSTANT_INTEGER(l_stride) && IS_CONSTANT_INTEGER(r_stride) + && gfc_dep_difference (l_start, r_start, &tmp)) { - mpz_t gcd, tmp; + mpz_t gcd; int result; mpz_init (gcd); - mpz_init (tmp); - mpz_gcd (gcd, l_stride->value.integer, r_stride->value.integer); - mpz_sub (tmp, l_start->value.integer, r_start->value.integer); mpz_fdiv_r (tmp, tmp, gcd); result = mpz_cmp_si (tmp, 0L); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index f28a99a78bf..4ebe9872b28 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2969,6 +2969,7 @@ gfc_namespace* gfc_build_block_ns (gfc_namespace *); /* dependency.c */ int gfc_dep_compare_functions (gfc_expr *, gfc_expr *, bool); int gfc_dep_compare_expr (gfc_expr *, gfc_expr *); +bool gfc_dep_difference (gfc_expr *, gfc_expr *, mpz_t *); /* check.c */ gfc_try gfc_check_same_strlen (const gfc_expr*, const gfc_expr*, const char*); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 06afc4f63e0..d0a9446fcce 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1437,6 +1437,7 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, gfc_se start; gfc_se end; char *msg; + mpz_t length; type = gfc_get_character_type (kind, ref->u.ss.length); type = build_pointer_type (type); @@ -1520,10 +1521,19 @@ gfc_conv_substring (gfc_se * se, gfc_ref * ref, int kind, free (msg); } - /* If the start and end expressions are equal, the length is one. */ + /* Try to calculate the length from the start and end expressions. */ if (ref->u.ss.end - && gfc_dep_compare_expr (ref->u.ss.start, ref->u.ss.end) == 0) - tmp = build_int_cst (gfc_charlen_type_node, 1); + && gfc_dep_difference (ref->u.ss.end, ref->u.ss.start, &length)) + { + int i_len; + + i_len = mpz_get_si (length) + 1; + if (i_len < 0) + i_len = 0; + + tmp = build_int_cst (gfc_charlen_type_node, i_len); + mpz_clear (length); /* Was initialized by gfc_dep_difference. */ + } else { tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_charlen_type_node, diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index a24b837c4be..a7ccaadacf6 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,9 @@ +2013-03-28 Thomas Koenig + + PR fortran/45159 + * gfortran.dg/string_length_2.f90: New test. + * gfortran.dg/dependency_41.f90: New test. + 2013-03-28 Thomas Koenig PR fortran/55806 diff --git a/gcc/testsuite/gfortran.dg/dependency_41.f90 b/gcc/testsuite/gfortran.dg/dependency_41.f90 new file mode 100644 index 00000000000..db9e0e6288e --- /dev/null +++ b/gcc/testsuite/gfortran.dg/dependency_41.f90 @@ -0,0 +1,19 @@ +! { dg-do run } +! { dg-options "-Warray-temporaries" } +! No temporary should be generated in this case. +program main + implicit none + integer :: i,n + integer :: a(10) + integer :: b(10) + do i=1,10 + a(i) = i + b(i) = i + end do + n = 1 + ! Same result when assigning to a or b + b(n+1:10:4) = a(n+2:8:2) + a(n+1:10:4) = a(n+2:8:2) + if (any (a/=b)) call abort +end program main + diff --git a/gcc/testsuite/gfortran.dg/string_length_2.f90 b/gcc/testsuite/gfortran.dg/string_length_2.f90 new file mode 100644 index 00000000000..63cea9e1dab --- /dev/null +++ b/gcc/testsuite/gfortran.dg/string_length_2.f90 @@ -0,0 +1,32 @@ +! { dg-run } +! { dg-options "-fdump-tree-original" } +! Test that all string length calculations are +! optimized away. +program main + character (len=999) :: c + character (len=5) :: unit + unit = ' ' + read (unit=unit,fmt='(I5)') i ! Hide from optimizers + j = 7 + c = '123456789' + if (len(c( 3 : 5 )) /= 3) call abort ! Case 1 + if (len(c( i*(i+1) : (i+1)*i + 2 )) /= 3) call abort ! Case 2 + if (len(c( i*(i+1) : 2 + (i+1)*i )) /= 3) call abort ! Case 3 + if (len(c( i*(i+1) + 2 : (i+1)*i + 3 )) /= 2) call abort ! Case 4 + if (len(c( 2 + i*(i+1) : (i+1)*i + 3 )) /= 2) call abort ! Case 5 + if (len(c( i*(i+1) + 2 : 3 + (i+1)*i )) /= 2) call abort ! Case 6 + if (len(c( 2 + i*(i+1) : 3 + (i+1)*i )) /= 2) call abort ! Case 7 + if (len(c( i*(i+1) - 1 : (i+1)*i + 1 )) /= 3) call abort ! Case 8 + if (len(c( i*(i+1) - 1 : 1 + (i+1)*i )) /= 3) call abort ! Case 9 + if (len(c( i*(i+1) : (i+1)*i -(-1))) /= 2) call abort ! Case 10 + if (len(c( i*(i+1) +(-2): (i+1)*i - 1 )) /= 2) call abort ! Case 11 + if (len(c( i*(i+1) + 2 : (i+1)*i -(-4))) /= 3) call abort ! Case 12 + if (len(c( i*(i+1) - 3 : (i+1)*i - 1 )) /= 3) call abort ! Case 13 + if (len(c(13 - i*(i+1) :15 - (i+1)*i )) /= 3) call abort ! Case 14 + if (len(c( i*(i+1) +(-1): (i+1)*i )) /= 2) call abort ! Case 15 + if (len(c(-1 + i*(i+1) : (i+1)*i )) /= 2) call abort ! Case 16 + if (len(c( i*(i+1) - 2 : (i+1)*i )) /= 3) call abort ! Case 17 + if (len(c( (i-2)*(i-3) : (i-3)*(i-2) )) /= 1) call abort ! Case 18 +end program main +! { dg-final { scan-tree-dump-times "_abort" 0 "original" } } +! { dg-final { cleanup-tree-dump "original" } }