re PR fortran/22572 (Double occurrence of matmul intrinsic not optimised)

2010-03-21  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/22572
	* gfortran.h (gfc_option_t) : Add
	flag_aggressive_function_elimination.
	(gfc_dep_compare_functions):  Add prototype.
	* lang.opt: Add faggressive-function-elimination.
	* invoke.texi: Document -faggressive-function-elimination.
	* frontend_passes (expr_array):  New static variable.
	(expr_size):  Likewise.
	(expr_count):  Likewise.
	(current_code):  Likewise.
	(current_ns):  Likewise.
	(gfc_run_passes):  Allocate and free space for expressions.
	(cfe_register_funcs):  New function.
	(create_var):  New function.
	(cfc_expr_0):  New function.
	(cfe_code):  New function.
	(optimize_namespace):  Invoke gfc_code_walker with cfe_code
	and cfe_expr_0.
	* dependency.c (gfc_dep_compare_functions):  New function.
	(gfc_dep_compare_expr):  Use it.
	* options.c (gfc_init_options):  Handle
	flag_aggressive_function_elimination.
	(gfc_handle_option):  Likewise.

2010-03-21  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/22572
	* gfortran.dg/function_optimize_1.f90:  New test.
	* gfortran.dg/function_optimize_2.f90:  New test.

From-SVN: r171207

10 files changed, 417 insertions, 31 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 05f8e6b..4e0a792 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,29 @@
+2010-03-21  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/22572
+	* gfortran.h (gfc_option_t) : Add
+	flag_aggressive_function_elimination.
+	(gfc_dep_compare_functions):  Add prototype.
+	* lang.opt: Add faggressive-function-elimination.
+	* invoke.texi: Document -faggressive-function-elimination.
+	* frontend_passes (expr_array):  New static variable.
+	(expr_size):  Likewise.
+	(expr_count):  Likewise.
+	(current_code):  Likewise.
+	(current_ns):  Likewise.
+	(gfc_run_passes):  Allocate and free space for expressions.
+	(cfe_register_funcs):  New function.
+	(create_var):  New function.
+	(cfc_expr_0):  New function.
+	(cfe_code):  New function.
+	(optimize_namespace):  Invoke gfc_code_walker with cfe_code
+	and cfe_expr_0.
+	* dependency.c (gfc_dep_compare_functions):  New function.
+	(gfc_dep_compare_expr):  Use it.
+	* options.c (gfc_init_options):  Handle
+	flag_aggressive_function_elimination.
+	(gfc_handle_option):  Likewise.
+
 2011-03-15  Francois-Xavier Coudert  <fxcoudert@gcc.gnu.org>
 
 	* arith.c (arith_power): Plug memory leak.
diff --git a/gcc/fortran/dependency.c b/gcc/fortran/dependency.c
index 77e8df7..adfcd2a 100644
--- a/gcc/fortran/dependency.c
+++ b/gcc/fortran/dependency.c
@@ -177,6 +177,49 @@ gfc_are_identical_variables (gfc_expr *e1, gfc_expr *e2)
   return true;
 }
 
+/* Compare two functions for equality.  Returns 0 if e1==e2, -2 otherwise.  If
+   impure_ok is false, only return 0 for pure functions.  */
+
+int
+gfc_dep_compare_functions (gfc_expr *e1, gfc_expr *e2, bool impure_ok)
+{
+
+  gfc_actual_arglist *args1;
+  gfc_actual_arglist *args2;
+  
+  if (e1->expr_type != EXPR_FUNCTION || e2->expr_type != EXPR_FUNCTION)
+    return -2;
+
+  if ((e1->value.function.esym && e2->value.function.esym
+       && e1->value.function.esym == e2->value.function.esym
+       && (e1->value.function.esym->result->attr.pure || impure_ok))
+       || (e1->value.function.isym && e2->value.function.isym
+	   && e1->value.function.isym == e2->value.function.isym
+	   && (e1->value.function.isym->pure || impure_ok)))
+    {
+      args1 = e1->value.function.actual;
+      args2 = e2->value.function.actual;
+
+      /* Compare the argument lists for equality.  */
+      while (args1 && args2)
+	{
+	  /*  Bitwise xor, since C has no non-bitwise xor operator.  */
+	  if ((args1->expr == NULL) ^ (args2->expr == NULL))
+	    return -2;
+	  
+	  if (args1->expr != NULL && args2->expr != NULL
+	      && gfc_dep_compare_expr (args1->expr, args2->expr) != 0)
+	    return -2;
+	  
+	  args1 = args1->next;
+	  args2 = args2->next;
+	}
+      return (args1 || args2) ? -2 : 0;
+    }
+      else
+	return -2;      
+}
+
 /* Compare two values.  Returns 0 if e1 == e2, -1 if e1 < e2, +1 if e1 > e2,
    and -2 if the relationship could not be determined.  */
 
@@ -399,36 +442,7 @@ gfc_dep_compare_expr (gfc_expr *e1, gfc_expr *e2)
       return -2;
 
     case EXPR_FUNCTION:
-
-      /* PURE functions can be compared for argument equality.  */
-      if ((e1->value.function.esym && e2->value.function.esym
-	   && e1->value.function.esym == e2->value.function.esym
-	   && e1->value.function.esym->result->attr.pure)
-	  || (e1->value.function.isym && e2->value.function.isym
-	      && e1->value.function.isym == e2->value.function.isym
-	      && e1->value.function.isym->pure))
-	{
-	  args1 = e1->value.function.actual;
-	  args2 = e2->value.function.actual;
-
-	  /* Compare the argument lists for equality.  */
-	  while (args1 && args2)
-	    {
-	      /*  Bitwise xor, since C has no non-bitwise xor operator.  */
-	      if ((args1->expr == NULL) ^ (args2->expr == NULL))
-		return -2;
-
-	      if (args1->expr != NULL && args2->expr != NULL
-		  && gfc_dep_compare_expr (args1->expr, args2->expr) != 0)
-		return -2;
-
-	      args1 = args1->next;
-	      args2 = args2->next;
-	    }
-	  return (args1 || args2) ? -2 : 0;
-	}
-      else
-	return -2;
+      return gfc_dep_compare_functions (e1, e2, false);
       break;
 
     default:
diff --git a/gcc/fortran/frontend-passes.c b/gcc/fortran/frontend-passes.c
index 7c55767..e26ae68 100644
--- a/gcc/fortran/frontend-passes.c
+++ b/gcc/fortran/frontend-passes.c
@@ -40,6 +40,21 @@ static bool optimize_trim (gfc_expr *);
 
 static int count_arglist;
 
+/* Pointer to an array of gfc_expr ** we operate on, plus its size
+   and counter.  */
+
+static gfc_expr ***expr_array;
+static int expr_size, expr_count;
+
+/* Pointer to the gfc_code we currently work on - to be able to insert
+   a statement before.  */
+
+static gfc_code **current_code;
+
+/* The namespace we are currently dealing with.  */
+
+gfc_namespace *current_ns;
+
 /* Entry point - run all passes for a namespace.  So far, only an
    optimization pass is run.  */
 
@@ -48,9 +63,16 @@ gfc_run_passes (gfc_namespace *ns)
 {
   if (optimize)
     {
+      expr_size = 20;
+      expr_array = XNEWVEC(gfc_expr **, expr_size);
+
       optimize_namespace (ns);
       if (gfc_option.dump_fortran_optimized)
 	gfc_dump_parse_tree (ns, stdout);
+
+      /* FIXME: The following should be XDELETEVEC(expr_array);
+      but we cannot do that because it depends on free.  */
+      gfc_free (expr_array);
     }
 }
 
@@ -106,11 +128,214 @@ optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
   return 0;
 }
 
+
+/* Callback function for common function elimination, called from cfe_expr_0.
+   Put all eligible function expressions into expr_array.  We can't do
+   allocatable functions.  */
+
+static int
+cfe_register_funcs (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+	  void *data ATTRIBUTE_UNUSED)
+{
+  if ((*e)->expr_type != EXPR_FUNCTION)
+    return 0;
+
+  /* We don't do character functions (yet).  */
+  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 ((*e)->rank > 0 && (*e)->shape == NULL)
+    return 0;
+  
+  /* Skip the test for pure functions if -faggressive-function-elimination
+     is specified.  */
+  if ((*e)->value.function.esym)
+    {
+      if ((*e)->value.function.esym->attr.allocatable)
+	return 0;
+
+      /* Don't create an array temporary for elemental functions.  */
+      if ((*e)->value.function.esym->attr.elemental && (*e)->rank > 0)
+	return 0;
+
+      /* Only eliminate potentially impure functions if the
+	 user specifically requested it.  */
+      if (!gfc_option.flag_aggressive_function_elimination
+	  && !(*e)->value.function.esym->attr.pure
+	  && !(*e)->value.function.esym->attr.implicit_pure)
+	return 0;
+    }
+
+  if ((*e)->value.function.isym)
+    {
+      /* Conversions are handled on the fly by the middle end,
+	 transpose during trans-* stages.  */
+      if ((*e)->value.function.isym->id == GFC_ISYM_CONVERSION
+	  || (*e)->value.function.isym->id == GFC_ISYM_TRANSPOSE)
+	return 0;
+
+      /* Don't create an array temporary for elemental functions,
+	 as this would be wasteful of memory.
+	 FIXME: Create a scalar temporary during scalarization.  */
+      if ((*e)->value.function.isym->elemental && (*e)->rank > 0)
+	return 0;
+
+      if (!(*e)->value.function.isym->pure)
+	return 0;
+    }
+
+  if (expr_count >= expr_size)
+    {
+      expr_size += expr_size;
+      expr_array = XRESIZEVEC(gfc_expr **, expr_array, expr_size);
+    }
+  expr_array[expr_count] = e;
+  expr_count ++;
+  return 0;
+}
+
+/* Returns a new expression (a variable) to be used in place of the old one,
+   with an an assignment statement before the current statement to set
+   the value of the variable.  */
+
+static gfc_expr*
+create_var (gfc_expr * e)
+{
+  char name[GFC_MAX_SYMBOL_LEN +1];
+  static int num = 1;
+  gfc_symtree *symtree;
+  gfc_symbol *symbol;
+  gfc_expr *result;
+  gfc_code *n;
+  int i;
+
+  sprintf(name, "__var_%d",num++);
+  if (gfc_get_sym_tree (name, current_ns, &symtree, false) != 0)
+    gcc_unreachable ();
+
+  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++)
+    {
+      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;
+    }
+
+  symbol->attr.flavor = FL_VARIABLE;
+  symbol->attr.referenced = 1;
+  symbol->attr.dimension = e->rank > 0;
+  gfc_commit_symbol (symbol);
+
+  result = gfc_get_expr ();
+  result->expr_type = EXPR_VARIABLE;
+  result->ts = e->ts;
+  result->rank = e->rank;
+  result->shape = gfc_copy_shape (e->shape, e->rank);
+  result->symtree = symtree;
+  result->where = e->where;
+  if (e->rank > 0)
+    {
+      result->ref = gfc_get_ref ();
+      result->ref->type = REF_ARRAY;
+      result->ref->u.ar.type = AR_FULL;
+      result->ref->u.ar.where = e->where;
+      result->ref->u.ar.as = symbol->as;
+    }
+
+  /* Generate the new assignment.  */
+  n = XCNEW (gfc_code);
+  n->op = EXEC_ASSIGN;
+  n->loc = (*current_code)->loc;
+  n->next = *current_code;
+  n->expr1 = gfc_copy_expr (result);
+  n->expr2 = e;
+  *current_code = n;
+
+  return result;
+}
+
+/* Callback function for the code walker for doing common function
+   elimination.  This builds up the list of functions in the expression
+   and goes through them to detect duplicates, which it then replaces
+   by variables.  */
+
+static int
+cfe_expr_0 (gfc_expr **e, int *walk_subtrees,
+	  void *data ATTRIBUTE_UNUSED)
+{
+  int i,j;
+  gfc_expr *newvar;
+
+  expr_count = 0;
+
+  gfc_expr_walker (e, cfe_register_funcs, NULL);
+
+  /* Walk backwards through all the functions to make sure we
+     catch the leaf functions first.  */
+  for (i=expr_count-1; i>=1; i--)
+    {
+      /* Skip if the function has been replaced by a variable already.  */
+      if ((*(expr_array[i]))->expr_type == EXPR_VARIABLE)
+	continue;
+
+      newvar = NULL;
+      for (j=i-1; j>=0; j--)
+	{
+	  if (gfc_dep_compare_functions(*(expr_array[i]),
+					*(expr_array[j]), true)	== 0)
+	    {
+	      if (newvar == NULL)
+		newvar = create_var (*(expr_array[i]));
+	      gfc_free (*(expr_array[j]));
+	      *(expr_array[j]) = gfc_copy_expr (newvar);
+	    }
+	}
+      if (newvar)
+	*(expr_array[i]) = newvar;
+    }
+
+  /* We did all the necessary walking in this function.  */
+  *walk_subtrees = 0;
+  return 0;
+}
+
+/* Callback function for common function elimination, called from
+   gfc_code_walker.  This keeps track of the current code, in order
+   to insert statements as needed.  */
+
+static int
+cfe_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+	  void *data ATTRIBUTE_UNUSED)
+{
+  current_code = c;
+  return 0;
+}
+
 /* Optimize a namespace, including all contained namespaces.  */
 
 static void
 optimize_namespace (gfc_namespace *ns)
 {
+
+  current_ns = ns;
+
+  gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL);
   gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL);
 
   for (ns = ns->contained; ns; ns = ns->sibling)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index b64fa20..cd71f3b 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2232,6 +2232,7 @@ typedef struct
   int flag_whole_file;
   int flag_protect_parens;
   int flag_realloc_lhs;
+  int flag_aggressive_function_elimination;
 
   int fpe;
   int rtcheck;
@@ -2865,6 +2866,7 @@ void gfc_global_used (gfc_gsymbol *, locus *);
 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 *);
 
 /* check.c */
diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi
index 22245c9..d7388d0 100644
--- a/gcc/fortran/invoke.texi
+++ b/gcc/fortran/invoke.texi
@@ -1468,6 +1468,18 @@ need to be in effect.
 An allocatable left-hand side of an intrinsic assignment is automatically
 (re)allocated if it is either unallocated or has a different shape. The
 option is enabled by default except when @option{-std=f95} is given.
+
+@item -faggressive-function-elimination
+@opindex @code{faggressive-function-elimination}
+@cindex Elimination of functions with identical argument lists
+Functions with identical argument lists are eliminated within
+statements, regardless of whether these functions are marked
+@code{PURE} or not. For example, in
+@smallexample
+  a = f(b,c) + f(b,c)
+@end smallexample
+there will only be a single call to @code{f}.
+
 @end table
 
 @xref{Code Gen Options,,Options for Code Generation Conventions,
@@ -1475,7 +1487,6 @@ gcc,Using the GNU Compiler Collection (GCC)}, for information on more options
 offered by the GBE
 shared by @command{gfortran}, @command{gcc}, and other GNU compilers.
 
-
 @c man end
 
 @node Environment Variables
diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt
index 69b3144..9de70ac 100644
--- a/gcc/fortran/lang.opt
+++ b/gcc/fortran/lang.opt
@@ -278,6 +278,10 @@ d
 Fortran Joined
 ; Documented in common.opt
 
+faggressive-function-elimination
+Fortran
+Eliminate multiple function invokations also for impure functions
+
 falign-commons
 Fortran
 Enable alignment of COMMON blocks
diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c
index c116103..172fed8 100644
--- a/gcc/fortran/options.c
+++ b/gcc/fortran/options.c
@@ -150,6 +150,7 @@ gfc_init_options (unsigned int decoded_options_count,
   gfc_option.flag_align_commons = 1;
   gfc_option.flag_protect_parens = 1;
   gfc_option.flag_realloc_lhs = -1;
+  gfc_option.flag_aggressive_function_elimination = 0;
   
   gfc_option.fpe = 0;
   gfc_option.rtcheck = 0;
@@ -972,6 +973,10 @@ gfc_handle_option (size_t scode, const char *arg, int value,
       gfc_option.flag_align_commons = value;
       break;
 
+    case  OPT_faggressive_function_elimination:
+      gfc_option.flag_aggressive_function_elimination = value;
+      break;
+
     case OPT_fprotect_parens:
       gfc_option.flag_protect_parens = value;
       break;
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 251ffe7..259bcc0 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,9 @@
+2010-03-21  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/22572
+	* gfortran.dg/function_optimize_1.f90:  New test.
+	* gfortran.dg/function_optimize_2.f90:  New test.
+
 2011-03-20  H.J. Lu  <hongjiu.lu@intel.com>
 
 	PR rtl-optimization/47502
diff --git a/gcc/testsuite/gfortran.dg/function_optimize_1.f90 b/gcc/testsuite/gfortran.dg/function_optimize_1.f90
new file mode 100644
index 0000000..eaa915f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/function_optimize_1.f90
@@ -0,0 +1,46 @@
+! { dg-do compile }
+! { dg-options "-O -fdump-tree-original" }
+program main
+  implicit none
+  real, dimension(2,2) :: a, b, c, d
+  integer :: i
+  real :: x, z
+  character(60) :: line
+  real, external :: ext_func
+  interface
+     elemental function element(x)
+       real, intent(in) :: x
+       real :: elem
+     end function element
+     pure function mypure(x)
+       real, intent(in) :: x
+       integer :: mypure
+     end function mypure
+     elemental impure function elem_impure(x)
+       real, intent(in) :: x
+       real :: elem_impure
+     end function elem_impure
+  end interface
+
+  data a /2., 3., 5., 7./
+  data b /11., 13., 17., 23./
+  write (unit=line, fmt='(4F7.2)') matmul(a,b) + matmul(a,b)
+  z = sin(x) + cos(x) + sin(x) + cos(x)
+  print *,z
+  x = ext_func(a) + 23 + ext_func(a)
+  print *,d,x
+  z = element(x) + element(x)
+  print *,z
+  i = mypure(x) - mypure(x)
+  print *,i
+  z = elem_impure(x) - elem_impure(x)
+  print *,z
+end program main
+! { dg-final { scan-tree-dump-times "matmul_r4" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_sinf" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_cosf" 1 "original" } }
+! { dg-final { scan-tree-dump-times "ext_func" 2 "original" } }
+! { dg-final { scan-tree-dump-times "element" 1 "original" } }
+! { dg-final { scan-tree-dump-times "mypure" 1 "original" } }
+! { dg-final { scan-tree-dump-times "elem_impure" 2 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
diff --git a/gcc/testsuite/gfortran.dg/function_optimize_2.f90 b/gcc/testsuite/gfortran.dg/function_optimize_2.f90
new file mode 100644
index 0000000..8105661
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/function_optimize_2.f90
@@ -0,0 +1,47 @@
+! { dg-do compile }
+! { dg-options "-O -faggressive-function-elimination -fdump-tree-original" }
+program main
+  implicit none
+  real, dimension(2,2) :: a, b, c, d
+  real :: x, z
+  integer :: i
+  character(60) :: line
+  real, external :: ext_func
+  interface
+     elemental function element(x)
+       real, intent(in) :: x
+       real :: elem
+     end function element
+     pure function mypure(x)
+       real, intent(in) :: x
+       integer :: mypure
+     end function mypure
+     elemental impure function elem_impure(x)
+       real, intent(in) :: x
+       real :: elem_impure
+     end function elem_impure
+  end interface
+
+  data a /2., 3., 5., 7./
+  data b /11., 13., 17., 23./
+  write (unit=line, fmt='(4F7.2)') matmul(a,b) + matmul(a,b)
+  x = 1.2
+  z = sin(x) + cos(x) + sin(x) + cos(x)
+  print *,z
+  x = ext_func(a) + 23 + ext_func(a)
+  print *,d,x
+  z = element(x) + element(x)
+  print *,z
+  i = mypure(x) - mypure(x)
+  print *,i
+  z = elem_impure(x) - elem_impure(x)
+  print *,z
+end program main
+! { dg-final { scan-tree-dump-times "matmul_r4" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_sinf" 1 "original" } }
+! { dg-final { scan-tree-dump-times "__builtin_cosf" 1 "original" } }
+! { dg-final { scan-tree-dump-times "ext_func" 1 "original" } }
+! { dg-final { scan-tree-dump-times "element" 1 "original" } }
+! { dg-final { scan-tree-dump-times "mypure" 1 "original" } }
+! { dg-final { scan-tree-dump-times "elem_impure" 1 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }