re PR fortran/40628 (Assignment using "= trim(string)": Optimize "trim" away)

2010-07-25  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/40628
	* Make-lang.in:  Add fortran/frontend-passes.o.
	* gfortran.h:  Add prototype for gfc_run_passes.
	* resolve.c (gfc_resolve):  Call gfc_run_passes.
	* frontend-passes.c:  New file.

2010-07-25  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/40628
	* trim_optimize_1.f90:  New test.
	* character_comparision_1.f90:  New test.

From-SVN: r162519

gcc/fortran/ChangeLog

+2010-07-25  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/40628
+	* Make-lang.in:  Add fortran/frontend-passes.o.
+	* gfortran.h:  Add prototype for gfc_run_passes.
+	* resolve.c (gfc_resolve):  Call gfc_run_passes.
+	* frontend-passes.c:  New file.
+
 2010-07-25  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR fortran/42852

gcc/fortran/Make-lang.in

@@ -66,7 +66,7 @@ F95_OBJS = $(F95_PARSER_OBJS) $(FORTRAN_TARGET_OBJS) \
     fortran/trans.o fortran/trans-array.o fortran/trans-common.o \
     fortran/trans-const.o fortran/trans-decl.o fortran/trans-expr.o \
     fortran/trans-intrinsic.o fortran/trans-io.o fortran/trans-openmp.o \
-    fortran/trans-stmt.o fortran/trans-types.o
+    fortran/trans-stmt.o fortran/trans-types.o fortran/frontend-passes.o
 
 fortran_OBJS = $(F95_OBJS) gfortranspec.o
 

gcc/fortran/frontend-passes.c

+/* Pass manager for Fortran front end.
+   Copyright (C) 2010 Free Software Foundation, Inc.
+   Contributed by Thomas König.
+
+This file is part of GCC.
+
+GCC is free software; you can redistribute it and/or modify it under
+the terms of the GNU General Public License as published by the Free
+Software Foundation; either version 3, or (at your option) any later
+version.
+
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+for more details.
+
+You should have received a copy of the GNU General Public License
+along with GCC; see the file COPYING3.  If not see
+<http://www.gnu.org/licenses/>.  */
+
+#include "config.h"
+#include "system.h"
+#include "gfortran.h"
+#include "arith.h"
+#include "flags.h"
+
+/* Forward declarations.  */
+
+static void strip_function_call (gfc_expr *);
+static void optimize_assignment (gfc_code *);
+static void optimize_expr_0 (gfc_expr *);
+static bool optimize_expr (gfc_expr *);
+static bool optimize_op (gfc_expr *);
+static bool optimize_equality (gfc_expr *, bool);
+static void optimize_code (gfc_code *);
+static void optimize_code_node (gfc_code *);
+static void optimize_actual_arglist (gfc_actual_arglist *);
+
+/* Entry point - run all passes for a namespace.  So far, only an
+   optimization pass is run.  */
+
+void
+gfc_run_passes (gfc_namespace * ns)
+{
+  if (optimize)
+    optimize_code (ns->code);
+}
+
+static void
+optimize_code (gfc_code *c)
+{
+  for (; c; c = c->next)
+    optimize_code_node (c);
+}
+
+
+/* Do the optimizations for a code node.  */
+
+static void
+optimize_code_node (gfc_code *c)
+{
+
+  gfc_forall_iterator *fa;
+  gfc_code *d;
+  gfc_alloc *a;
+
+  switch (c->op)
+    {
+    case EXEC_ASSIGN:
+      optimize_assignment (c);
+      break;
+
+    case EXEC_CALL:
+    case EXEC_ASSIGN_CALL:
+    case EXEC_CALL_PPC:
+      optimize_actual_arglist (c->ext.actual);
+      break;
+
+    case EXEC_ARITHMETIC_IF:
+      optimize_expr_0 (c->expr1);
+      break;
+
+    case EXEC_PAUSE:
+    case EXEC_RETURN:
+    case EXEC_ERROR_STOP:
+    case EXEC_STOP:
+    case EXEC_COMPCALL:
+      optimize_expr_0 (c->expr1);
+      break;
+
+    case EXEC_SYNC_ALL:
+    case EXEC_SYNC_MEMORY:
+    case EXEC_SYNC_IMAGES:
+      optimize_expr_0 (c->expr2);
+      break;
+
+    case EXEC_IF:
+      d = c->block;
+      optimize_expr_0 (d->expr1);
+      optimize_code (d->next);
+
+      for (d = d->block; d; d = d->block)
+	{
+	  optimize_expr_0 (d->expr1);
+
+	  optimize_code (d->next);
+	}
+
+
+      break;
+
+    case EXEC_SELECT:
+    case EXEC_SELECT_TYPE:
+      d = c->block;
+
+      optimize_expr_0 (c->expr1);
+
+      for (; d; d = d->block)
+	optimize_code (d->next);
+
+      break;
+
+    case EXEC_WHERE:
+      d = c->block;
+      optimize_expr_0 (d->expr1);
+      optimize_code (d->next);
+
+      for (d = d->block; d; d = d->block)
+	{
+	  optimize_expr_0 (d->expr1);
+	  optimize_code (d->next);
+	}
+      break;
+
+    case EXEC_FORALL:
+
+      for (fa = c->ext.forall_iterator; fa; fa = fa->next)
+	{
+	  optimize_expr_0 (fa->start);
+	  optimize_expr_0 (fa->end);
+	  optimize_expr_0 (fa->stride);
+	}
+
+      if (c->expr1 != NULL)
+	  optimize_expr_0 (c->expr1);
+
+      optimize_code (c->block->next);
+
+      break;
+
+    case EXEC_CRITICAL:
+      optimize_code (c->block->next);
+      break;
+
+    case EXEC_DO:
+      optimize_expr_0 (c->ext.iterator->start);
+      optimize_expr_0 (c->ext.iterator->end);
+      optimize_expr_0 (c->ext.iterator->step);
+      optimize_code (c->block->next);
+
+      break;
+
+    case EXEC_DO_WHILE:
+      optimize_expr_0 (c->expr1);
+      optimize_code (c->block->next);
+      break;
+
+
+    case EXEC_ALLOCATE:
+      for (a = c->ext.alloc.list; a; a = a->next)
+	  optimize_expr_0 (a->expr);
+      break;
+
+      /* Todo:  Some of these may need to be optimized, as well.  */
+    case EXEC_WRITE:
+    case EXEC_READ:
+    case EXEC_OPEN:
+    case EXEC_INQUIRE:
+    case EXEC_REWIND:
+    case EXEC_ENDFILE:
+    case EXEC_BACKSPACE:
+    case EXEC_CLOSE:
+    case EXEC_WAIT:
+    case EXEC_TRANSFER:
+    case EXEC_FLUSH:
+    case EXEC_IOLENGTH:
+    case EXEC_END_PROCEDURE:
+    case EXEC_NOP:
+    case EXEC_CONTINUE:
+    case EXEC_ENTRY:
+    case EXEC_INIT_ASSIGN:
+    case EXEC_LABEL_ASSIGN:
+    case EXEC_POINTER_ASSIGN:
+    case EXEC_GOTO:
+    case EXEC_CYCLE:
+    case EXEC_EXIT:
+    case EXEC_BLOCK:
+    case EXEC_END_BLOCK:
+    case EXEC_OMP_ATOMIC:
+    case EXEC_OMP_BARRIER:
+    case EXEC_OMP_CRITICAL:
+    case EXEC_OMP_FLUSH:
+    case EXEC_OMP_DO:
+    case EXEC_OMP_MASTER:
+    case EXEC_OMP_ORDERED:
+    case EXEC_OMP_PARALLEL:
+    case EXEC_OMP_PARALLEL_DO:
+    case EXEC_OMP_PARALLEL_SECTIONS:
+    case EXEC_OMP_PARALLEL_WORKSHARE:
+    case EXEC_OMP_SECTIONS:
+    case EXEC_OMP_SINGLE:
+    case EXEC_OMP_TASK:
+    case EXEC_OMP_TASKWAIT:
+    case EXEC_OMP_WORKSHARE:
+    case EXEC_DEALLOCATE:
+      
+      break;
+
+    default:
+      gcc_unreachable ();
+
+    }
+}
+
+/* Optimizations for an assignment.  */
+
+static void
+optimize_assignment (gfc_code * c)
+{
+  gfc_expr *lhs, *rhs;
+
+  lhs = c->expr1;
+  rhs = c->expr2;
+
+  /* Optimize away a = trim(b), where a is a character variable.  */
+
+  if (lhs->ts.type == BT_CHARACTER)
+    {
+      if (rhs->expr_type == EXPR_FUNCTION &&
+	  rhs->value.function.isym &&
+	  rhs->value.function.isym->id == GFC_ISYM_TRIM)
+	{
+	  strip_function_call (rhs);
+	  optimize_assignment (c);
+	  return;
+	}
+    }
+
+  /* All direct optimizations have been done.  Now it's time
+     to optimize the rhs.  */
+
+  optimize_expr_0 (rhs);
+}
+
+
+/* Remove an unneeded function call, modifying the expression.
+   This replaces the function call with the value of its
+   first argument.  The rest of the argument list is freed.  */
+
+static void
+strip_function_call (gfc_expr *e)
+{
+  gfc_expr *e1;
+  gfc_actual_arglist *a;
+
+  a = e->value.function.actual;
+
+  /* We should have at least one argument.  */
+  gcc_assert (a->expr != NULL);
+
+  e1 = a->expr;
+
+  /* Free the remaining arglist, if any.  */
+  if (a->next)
+    gfc_free_actual_arglist (a->next);
+
+  /* Graft the argument expression onto the original function.  */
+  *e = *e1;
+  gfc_free (e1);
+
+}
+
+/* Top-level optimization of expressions.  Calls gfc_simplify_expr if
+   optimize_expr succeeds in doing something.
+   TODO: Optimization of multiple function occurrence to come here.  */
+
+static void
+optimize_expr_0 (gfc_expr * e)
+{
+  if (optimize_expr (e))
+    gfc_simplify_expr (e, 0);
+
+  return;
+}
+
+/* Recursive optimization of expressions.
+ TODO:  Make this handle many more things.  */
+
+static bool
+optimize_expr (gfc_expr *e)
+{
+  bool ret;
+
+  if (e == NULL)
+    return false;
+
+  ret = false;
+
+  switch (e->expr_type)
+    {
+    case EXPR_OP:
+      return optimize_op (e);
+      break;
+
+    case EXPR_FUNCTION:
+      optimize_actual_arglist (e->value.function.actual);
+      break;
+
+    default:
+      break;
+    }
+
+  return ret;
+}
+
+/* Recursive optimization of operators.  */
+
+static bool
+optimize_op (gfc_expr *e)
+{
+
+  gfc_intrinsic_op op;
+
+  op = e->value.op.op;
+
+  switch (op)
+    {
+    case INTRINSIC_EQ:
+    case INTRINSIC_EQ_OS:
+    case INTRINSIC_GE:
+    case INTRINSIC_GE_OS:
+    case INTRINSIC_LE:
+    case INTRINSIC_LE_OS:
+      return optimize_equality (e, true);
+      break;
+
+    case INTRINSIC_NE:
+    case INTRINSIC_NE_OS:
+    case INTRINSIC_GT:
+    case INTRINSIC_GT_OS:
+    case INTRINSIC_LT:
+    case INTRINSIC_LT_OS:
+      return optimize_equality (e, false);
+      break;
+
+    default:
+      break;
+    }
+
+  return false;
+}
+
+/* Optimize expressions for equality.  */
+
+static bool
+optimize_equality (gfc_expr *e, bool equal)
+{
+
+  gfc_expr *op1, *op2;
+  bool change;
+
+  op1 = e->value.op.op1;
+  op2 = e->value.op.op2;
+
+  /* Strip off unneeded TRIM calls from string comparisons.  */
+
+  change = false;
+
+  if (op1->expr_type == EXPR_FUNCTION 
+      && op1->value.function.isym
+      && op1->value.function.isym->id == GFC_ISYM_TRIM)
+    {
+      strip_function_call (op1);
+      change = true;
+    }
+
+  if (op2->expr_type == EXPR_FUNCTION 
+      && op2->value.function.isym
+      && op2->value.function.isym->id == GFC_ISYM_TRIM)
+    {
+      strip_function_call (op2);
+      change = true;
+    }
+
+  if (change)
+    {
+      optimize_equality (e, equal);
+      return true;
+    }
+
+  /* Check for direct comparison between identical variables.
+     TODO: Handle cases with identical refs.  */
+  if (op1->expr_type == EXPR_VARIABLE
+      && op2->expr_type == EXPR_VARIABLE
+      && op1->symtree == op2->symtree
+      && op1->ref == NULL && op2->ref == NULL
+      && op1->ts.type != BT_REAL && op2->ts.type != BT_REAL
+      && op1->ts.type != BT_COMPLEX && op2->ts.type !=BT_COMPLEX)
+    {
+      /* Replace the expression by a constant expression.  The typespec
+	 and where remains the way it is.  */
+      gfc_free (op1);
+      gfc_free (op2);
+      e->expr_type = EXPR_CONSTANT;
+      e->value.logical = equal;
+      return true;
+    }
+  return false;
+}
+
+/* Optimize a call list.  Right now, this just goes through the actual
+   arg list and optimizes each expression in turn.  */
+
+static void
+optimize_actual_arglist (gfc_actual_arglist *a)
+{
+
+  for (; a; a = a->next)
+    {
+      if (a->expr != NULL)
+	optimize_expr_0 (a->expr);
+    }
+  
+  return;
+}

gcc/fortran/gfortran.h

@@ -2842,4 +2842,8 @@ gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*);
 
 #define CLASS_DATA(sym) sym->ts.u.derived->components
 
+/* frontend-passes.c */
+
+void gfc_run_passes (gfc_namespace *);
+
 #endif /* GCC_GFORTRAN_H  */

gcc/fortran/resolve.c

@@ -13081,4 +13081,6 @@ gfc_resolve (gfc_namespace *ns)
   gfc_current_ns = old_ns;
   cs_base = old_cs_base;
   ns->resolved = 1;
+
+  gfc_run_passes (ns);
 }

gcc/testsuite/ChangeLog

+2010-07-25  Thomas Koenig  <tkoenig@gcc.gnu.org>
+
+	PR fortran/40628
+	* trim_optimize_1.f90:  New test.
+	* character_comparision_1.f90:  New test.
+
 2010-07-25  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
 
 	PR fortran/42852

gcc/testsuite/gfortran.dg/character_comparison_1.f90

+! { dg-do run }
+! { dg-options "-O -fdump-tree-original" }
+program main
+  implicit none
+  character(len=4) :: c
+  integer :: n
+  integer :: i
+  common /foo/ i
+
+  n = 0
+  i = 0
+  c = 'abcd'
+  n = n + 1 ; if (c == c) call yes
+  n = n + 1 ; if (c >= c) call yes
+  n = n + 1 ; if (c <= c) call yes
+  n = n + 1 ; if (c .eq. c) call yes
+  n = n + 1 ; if (c .ge. c) call yes
+  n = n + 1 ; if (c .le. c) call yes
+  if (c /= c) call abort
+  if (c > c) call abort
+  if (c < c) call abort
+  if (c .ne. c) call abort
+  if (c .gt. c) call abort
+  if (c .lt. c) call abort
+  if (n /= i) call abort
+end program main
+
+subroutine yes
+  implicit none
+  common /foo/ i
+  integer :: i
+  i = i + 1
+end subroutine yes
+
+! { dg-final { scan-tree-dump-times "gfortran_compare_string" 0 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }
+

gcc/testsuite/gfortran.dg/trim_optimize_1.f90

+! { dg-do run }
+! { dg-options "-O -fdump-tree-original" }
+! PR 40628 - optimize unnecessary TRIMs on assignment
+program main
+  character(len=3) :: a
+  character(len=4) :: b,c
+  b = 'abcd'
+  a = trim(b)
+  c = trim(trim(a))
+  if (a /= 'abc') call abort
+  if (c /= 'abc') call abort
+end program main
+
+! { dg-final { scan-tree-dump-times "memmove" 2 "original" } }
+! { dg-final { scan-tree-dump-times "string_trim" 0 "original" } }
+! { dg-final { cleanup-tree-dump "original" } }