re PR fortran/52243 (Avoid reallocation for: array1 = array1 / scalar for performance)

2013-08-29  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/52243
	* trans-expr.c (is_runtime_conformable):  New function.
	* gfc_trans_assignment_1:  Use it.

2013-08-29  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/52243
	* gfortran.dg/realloc_on_assign_14.f90:  Remove warning made
	obsolete by patch.
	* gfortran.dg/realloc_on_assign_19.f90:  New test.

From-SVN: r202070

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 7e8326b..5fbe331 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,9 @@
+2013-08-29  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+       PR fortran/52243
+       * trans-expr.c (is_runtime_conformable):  New function.
+       * gfc_trans_assignment_1:  Use it.
+
 2013-08-26  Thomas Koenig  <tkoenig@gcc.gnu.org>
 
        PR fortran/58146

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index dd4c8fc..0ecfdfc 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -7738,6 +7738,105 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block,
     }
 }
 
+/* Check for assignments of the type
+
+   a = a + 4
+
+   to make sure we do not check for reallocation unneccessarily.  */
+
+
+static bool
+is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2)
+{
+  gfc_actual_arglist *a;
+  gfc_expr *e1, *e2;
+
+  switch (expr2->expr_type)
+    {
+    case EXPR_VARIABLE:
+      return gfc_dep_compare_expr (expr1, expr2) == 0;
+
+    case EXPR_FUNCTION:
+      if (expr2->value.function.esym
+         && expr2->value.function.esym->attr.elemental)
+       {
+         for (a = expr2->value.function.actual; a != NULL; a = a->next)
+           {
+             e1 = a->expr;
+             if (e1->rank > 0 && !is_runtime_conformable (expr1, e1))
+               return false;
+           }    
+         return true;
+       }
+      else if (expr2->value.function.isym
+              && expr2->value.function.isym->elemental)
+       {
+         for (a = expr2->value.function.actual; a != NULL; a = a->next)
+           {
+             e1 = a->expr;
+             if (e1->rank > 0 && !is_runtime_conformable (expr1, e1))
+               return false;
+           }
+         return true;
+       }
+
+      break;
+
+    case EXPR_OP:
+      switch (expr2->value.op.op)
+       {
+       case INTRINSIC_NOT:
+       case INTRINSIC_UPLUS:
+       case INTRINSIC_UMINUS:
+       case INTRINSIC_PARENTHESES:
+         return is_runtime_conformable (expr1, expr2->value.op.op1);
+
+       case INTRINSIC_PLUS:
+       case INTRINSIC_MINUS:
+       case INTRINSIC_TIMES:
+       case INTRINSIC_DIVIDE:
+       case INTRINSIC_POWER:
+       case INTRINSIC_AND:
+       case INTRINSIC_OR:
+       case INTRINSIC_EQV:
+       case INTRINSIC_NEQV:
+       case INTRINSIC_EQ:
+       case INTRINSIC_NE:
+       case INTRINSIC_GT:
+       case INTRINSIC_GE:
+       case INTRINSIC_LT:
+       case INTRINSIC_LE:
+       case INTRINSIC_EQ_OS:
+       case INTRINSIC_NE_OS:
+       case INTRINSIC_GT_OS:
+       case INTRINSIC_GE_OS:
+       case INTRINSIC_LT_OS:
+       case INTRINSIC_LE_OS:
+
+         e1 = expr2->value.op.op1;
+         e2 = expr2->value.op.op2;
+
+         if (e1->rank == 0 && e2->rank > 0)
+           return is_runtime_conformable (expr1, e2);
+         else if (e1->rank > 0 && e2->rank == 0)
+           return is_runtime_conformable (expr1, e1);
+         else if (e1->rank > 0 && e2->rank > 0)
+           return is_runtime_conformable (expr1, e1)
+             && is_runtime_conformable (expr1, e2);
+         break;
+
+       default:
+         break;
+
+       }
+
+      break;
+
+    default:
+      break;
+    }
+  return false;
+}
 
 /* Subroutine of gfc_trans_assignment that actually scalarizes the
    assignment.  EXPR1 is the destination/LHS and EXPR2 is the source/RHS.
@@ -7935,7 +8034,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
            && gfc_is_reallocatable_lhs (expr1)
            && !gfc_expr_attr (expr1).codimension
            && !gfc_is_coindexed (expr1)
-           && expr2->rank)
+           && expr2->rank
+           && !is_runtime_conformable (expr1, expr2))
        {
          realloc_lhs_warning (expr1->ts.type, true, &expr1->where);
          ompws_flags &= ~OMPWS_SCALARIZER_WS;

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index d95d535..3d54682 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2013-08-29  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+       PR fortran/52243
+       * gfortran.dg/realloc_on_assign_14.f90:  Remove warning made
+       obsolete by patch.
+       * gfortran.dg/realloc_on_assign_19.f90:  New test.
+
 2013-08-29  Richard Biener  <rguenther@suse.de>
 
        PR middle-end/57287

diff --git a/gcc/testsuite/gfortran.dg/realloc_on_assign_14.f90 b/gcc/testsuite/gfortran.dg/realloc_on_assign_14.f90
index 8474d18..b8b669f 100644 (file)
--- a/gcc/testsuite/gfortran.dg/realloc_on_assign_14.f90
+++ b/gcc/testsuite/gfortran.dg/realloc_on_assign_14.f90
@@ -23,7 +23,7 @@ str = 'abc'    ! { dg-warning "Code for reallocating the allocatable variable" }
 astr = 'abc'   ! no realloc
 astr = ['abc'] ! { dg-warning "Code for reallocating the allocatable array" }
 a = reshape(a,shape(a)) ! { dg-warning "Code for reallocating the allocatable array" }
-r = sin(r)     ! { dg-warning "Code for reallocating the allocatable array" }
+r = sin(r)
 r = sin(r(1))  ! no realloc
 b = sin(r(1))  ! { dg-warning "Code for reallocating the allocatable variable" }
 

diff --git a/gcc/testsuite/gfortran.dg/realloc_on_assign_19.f90 b/gcc/testsuite/gfortran.dg/realloc_on_assign_19.f90
new file mode 100644 (file)
index 0000000..c54a35f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/realloc_on_assign_19.f90
@@ -0,0 +1,21 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+! PR 52243 - avoid check for reallocation when doing simple
+! assignments with the same variable on both sides.
+module  foo
+contains
+  elemental function ele(a)
+    real, intent(in) :: a
+    real :: ele
+    ele = 1./(2+a)
+  end function ele
+
+  subroutine bar(a)
+    real, dimension(:), allocatable :: a
+    a = a * 2.0
+    a = sin(a-0.3)
+    a = ele(a)
+  end subroutine bar
+end module foo
+! { dg-final { scan-tree-dump-times "alloc" 0 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }