Patchwork [fortran] PR 52243 - avoid reallocation checks on assignment when possible

login
register
mail settings
Submitter Thomas Koenig
Date Aug. 28, 2013, 10:07 p.m.
Message ID <521E748A.2050809@netcologne.de>
Download mbox | patch
Permalink /patch/270645/
State New
Headers show

Comments

Thomas Koenig - Aug. 28, 2013, 10:07 p.m.
Hello world,

the attached patch avoids checks for reallocation on assignment when
the same variable is on both sides of the assignment.

Regression-tested.  OK for trunk?

	Thomas

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.
Tobias Burnus - Aug. 28, 2013, 10:53 p.m.
Dear Thomas, dear all,

Thomas Koenig wrote:
> the attached patch avoids checks for reallocation on assignment when
> the same variable is on both sides of the assignment.
>
> Regression-tested.  OK for trunk?

OK and thanks for the patch.  (Can you remove the trailing spaces in the 
line the first "return false;" before committal?)

Tobias

PS: I should have (again) more time for gfortran in the near future.

> 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.

Patch

Index: fortran/trans-expr.c
===================================================================
--- fortran/trans-expr.c	(Revision 201996)
+++ fortran/trans-expr.c	(Arbeitskopie)
@@ -7738,7 +7738,103 @@  alloc_scalar_allocatable_for_assignment (stmtblock
     }
 }
 
+/* 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;
+
+	}
+    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.
    init_flag indicates initialization expressions and dealloc that no
@@ -7935,7 +8031,8 @@  gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr
 	    && 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;
Index: testsuite/gfortran.dg/realloc_on_assign_14.f90
===================================================================
--- testsuite/gfortran.dg/realloc_on_assign_14.f90	(Revision 201996)
+++ testsuite/gfortran.dg/realloc_on_assign_14.f90	(Arbeitskopie)
@@ -23,7 +23,7 @@  str = 'abc'    ! { dg-warning "Code for reallocati
 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" }