[patch, fortran] Eliminate duplicate function calls with rank>0 and unknown shape

[Thomas Koenig <tkoenig at netcologne dot de>]

Hello world,

after Paul's fix for allocate on assignment (thanks Paul!), here is a
patch for the original test case from PR 22572, where the bounds of
the function are unknown at compile time.  This uses an allocatable
temporary.

In the long run, another option is to use interface mapping to evaluate
the bounds of intrinsics and explicit-shape functions.  For this, it
would be necessary to write a front-end-only version of 
gfc_evaluate_now, which would be complicated by the desire not to 
disturb common function elimination, so I've put that on the back burner 
for now.

Regression-tested.  OK for trunk?

	Thomas

2011-05-01  Thomas Koenig  <tkoenig@gcc.gnu.org>

        PR fortran/22572
        * frontend-passes.c (cfe_register_funcs):  Also register functions
        for potential elimination if the rank is > 0, the shape is unknown
        and reallocate on assignment is active.
        (create_var):  For rank > 0 functions with unknown shape, create
        an allocatable temporary.

2011-05-01  Thomas Koenig  <tkoenig@gcc.gnu.org>

        PR fortran/22572
        * function_optimize_7.f90:  New test case.

Index: frontend-passes.c
===================================================================
--- frontend-passes.c	(Revision 173214)
+++ frontend-passes.c	(Arbeitskopie)
@@ -152,11 +152,11 @@ cfe_register_funcs (gfc_expr **e, int *walk_subtre
   if ((*e)->ts.type == BT_CHARACTER)
     return 0;
 
-  /* If we don't know the shape at compile time, we do not create a temporary
-     variable to hold the intermediate result.  FIXME: Change this later when
-     allocation on assignment works for intrinsics.  */
+  /* If we don't know the shape at compile time, we create an allocatable
+     temporary variable to hold the intermediate result, but only if
+     allocation on assignment is active.  */
 
-  if ((*e)->rank > 0 && (*e)->shape == NULL)
+  if ((*e)->rank > 0 && (*e)->shape == NULL && !gfc_option.flag_realloc_lhs)
     return 0;
   
   /* Skip the test for pure functions if -faggressive-function-elimination
@@ -250,22 +250,38 @@ create_var (gfc_expr * e)
 
   symbol = symtree->n.sym;
   symbol->ts = e->ts;
-  symbol->as = gfc_get_array_spec ();
-  symbol->as->rank = e->rank;
-  symbol->as->type = AS_EXPLICIT;
-  for (i=0; i<e->rank; i++)
+
+  if (e->rank > 0)
     {
-      gfc_expr *p, *q;
+      symbol->as = gfc_get_array_spec ();
+      symbol->as->rank = e->rank;
+
+      if (e->shape == NULL)
+	{
+	  /* We don't know the shape at compile time, so we use an
+	     allocatable. */
+	  symbol->as->type = AS_DEFERRED;
+	  symbol->attr.allocatable = 1;
+	}
+      else
+	{
+	  symbol->as->type = AS_EXPLICIT;
+	  /* Copy the shape.  */
+	  for (i=0; i<e->rank; i++)
+	    {
+	      gfc_expr *p, *q;
       
-      p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
-				 &(e->where));
-      mpz_set_si (p->value.integer, 1);
-      symbol->as->lower[i] = p;
-	  
-      q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
-				 &(e->where));
-      mpz_set (q->value.integer, e->shape[i]);
-      symbol->as->upper[i] = q;
+	      p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+					 &(e->where));
+	      mpz_set_si (p->value.integer, 1);
+	      symbol->as->lower[i] = p;
+	      
+	      q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
+					 &(e->where));
+	      mpz_set (q->value.integer, e->shape[i]);
+	      symbol->as->upper[i] = q;
+	    }
+	}
     }
 
   symbol->attr.flavor = FL_VARIABLE;

Attachment: function_optimize_7.f90
Description: Text document