Patchwork [fortran] PR 47065 - some more trim optimizations

login
register
mail settings
Submitter Thomas Koenig
Date Feb. 20, 2011, 1:09 p.m.
Message ID <4D61128C.4080800@netcologne.de>
Download mbox | patch
Permalink /patch/83728/
State New
Headers show

Comments

Thomas Koenig - Feb. 20, 2011, 1:09 p.m.
Hello world,

the attached patch does the trim optimizations when there are
references, except substring references.  This was made possible by
Paul's fix to PR 47348.  Regression-tested.

OK for trunk?  Or should I rather wait until 4.6 is released?

2011-02-20  Thomas Koenig  <tkoenig@gcc.gnu.org>

        PR fortran/47065
        * frontend-passes (check_impure_function): New function.
        * optimize_trim: Also follow references, except when they are
        substring references.  Don't replace calls to trim with substrings
        if the substring indices contain impure functions.

2011-02-20  Thomas Koenig  <tkoenig@gcc.gnu.org>

        PR fortran/47065
        * gfortran.dg/trim_optimize_5.f90:  New test.
        * gfortran.dg/trim_optimize_6.f90:  New test.
! { dg-do run }
! { dg-options "-O -fdump-tree-original" }
! PR 47065 - replace trim with substring expressions even with references.
module foo
  implicit none
contains
  pure function f()
    integer :: f
    f = 2
  end function f
end module foo

program main
  use foo
  implicit none
  type t
     character(len=2) :: x
  end type t
  type(t) :: a
  character(len=3) :: b(4)
  character(len=10) :: line
  a%x = 'a'
  write(unit=line,fmt='(A,A)') trim(a%x),"X"
  if (line /= 'aX        ') call abort
  b(1) = 'ab'
  write(unit=line,fmt='(A,A)') trim(b(1)),"X"
  if (line /= 'abX       ') call abort
  b(2) = 'cd'
  write(unit=line,fmt='(A,A)') trim(b(f())),"X"
  if (line /= 'cdX       ') call abort  
end program main
! { dg-final { scan-tree-dump-times "string_len_trim" 3 "original" } }
! { dg-final { cleanup-tree-dump "original" }
! { dg-do run }
! PR 47065 - make sure that impure functions are not evaluated twice when
! replacing calls to trim with expression(1:len_trim)
module foo
  implicit none
contains
  function f()
    integer :: f
    integer :: s=0
    s = s + 1
    f = s
  end function f
end module foo

program main
  use foo
  implicit none
  character(len=10) :: line
  character(len=4) :: b(2)
  b(1) = 'a'
  b(2) = 'bc'
  write(unit=line,fmt='(A,A)') trim(b(f())), "X"
  if (line /= "aX          ") call abort
  if (f() .ne. 2) call abort
end program main
Mikael Morin - Feb. 24, 2011, 12:11 a.m.
On Sunday 20 February 2011 14:09:32 Thomas Koenig wrote:
> Hello world,
> 
> the attached patch does the trim optimizations when there are
> references, except substring references.  This was made possible by
> Paul's fix to PR 47348.  Regression-tested.
> 
> OK for trunk?  Or should I rather wait until 4.6 is released?

This looks good, but it doesn't seem to fix some broken things (in which case 
it is not for stage4). Please ping or repost during stage1.

Mikael

PS: by the way this chunk before the impure check must probably be updated:
   if (a->expr_type != EXPR_VARIABLE)
     return false;

Patch

Index: frontend-passes.c
===================================================================
--- frontend-passes.c	(Revision 170320)
+++ frontend-passes.c	(Arbeitskopie)
@@ -428,6 +428,27 @@  optimize_comparison (gfc_expr *e, gfc_intrinsic_op
   return false;
 }
 
+/* Callback for gfc_expr_walker to check for the presence of
+   an impure function in an expression.  */
+
+static int
+check_impure_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+		       void *data ATTRIBUTE_UNUSED)
+{
+  if ((*e)->expr_type == EXPR_FUNCTION)
+    {
+      if ((*e)->value.function.esym 
+	   && !(*e)->value.function.esym->result->attr.pure)
+	return 1;
+
+      if ((*e)->value.function.isym
+	  && !(*e)->value.function.isym->pure)
+	return 1;
+    }
+
+  return 0;
+}
+
 /* Optimize a trim function by replacing it with an equivalent substring
    involving a call to len_trim.  This only works for expressions where
    variables are trimmed.  Return true if anything was modified.  */
@@ -439,6 +460,7 @@  optimize_trim (gfc_expr *e)
   gfc_ref *ref;
   gfc_expr *fcn;
   gfc_actual_arglist *actual_arglist, *next;
+  gfc_ref **rr = NULL;
 
   /* Don't do this optimization within an argument list, because
      otherwise aliasing issues may occur.  */
@@ -456,46 +478,58 @@  optimize_trim (gfc_expr *e)
   if (a->expr_type != EXPR_VARIABLE)
     return false;
 
+  /* Don't do this optimization if might involve calling an impure
+     function.  FIXME:  Make it into a temporary variable later.  */
+
+  if (gfc_expr_walker (&e, check_impure_function, NULL))
+      return false;
+
+  /* Follow all references to find the correct place to put the newly
+     created reference.  FIXME:  Also handle substring references.  */
+
   if (a->ref)
     {
-      /* FIXME - also handle substring references, by modifying the
-	 reference itself.  Make sure not to evaluate functions in
-	 the references twice.  */
-      return false;
+      for (rr = &(a->ref); *rr; rr = &((*rr)->next))
+	{
+	  if ((*rr)->type == REF_SUBSTRING)
+	    return false;
+	}
     }
-  else
-    {
-      strip_function_call (e);
 
-      /* Create the reference.  */
+  strip_function_call (e);
 
-      ref = gfc_get_ref ();
-      ref->type = REF_SUBSTRING;
+  if (e->ref == NULL)
+    rr = &(e->ref);
 
-      /* Set the start of the reference.  */
+  /* Create the reference.  */
 
-      ref->u.ss.start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+  ref = gfc_get_ref ();
+  ref->type = REF_SUBSTRING;
 
-      /* Build the function call to len_trim(x, gfc_defaul_integer_kind).  */
+  /* Set the start of the reference.  */
 
-      fcn = gfc_get_expr ();
-      fcn->expr_type = EXPR_FUNCTION;
-      fcn->value.function.isym =
-	gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
-      actual_arglist = gfc_get_actual_arglist ();
-      actual_arglist->expr = gfc_copy_expr (e);
-      next = gfc_get_actual_arglist ();
-      next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
-				     gfc_default_integer_kind);
-      actual_arglist->next = next;
-      fcn->value.function.actual = actual_arglist;
+  ref->u.ss.start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
 
-      /* Set the end of the reference to the call to len_trim.  */
+  /* Build the function call to len_trim(x, gfc_defaul_integer_kind).  */
 
-      ref->u.ss.end = fcn;
-      e->ref = ref;
-      return true;
-    }
+  fcn = gfc_get_expr ();
+  fcn->expr_type = EXPR_FUNCTION;
+  fcn->value.function.isym =
+    gfc_intrinsic_function_by_id (GFC_ISYM_LEN_TRIM);
+  actual_arglist = gfc_get_actual_arglist ();
+  actual_arglist->expr = gfc_copy_expr (e);
+  next = gfc_get_actual_arglist ();
+  next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL,
+				 gfc_default_integer_kind);
+  actual_arglist->next = next;
+  fcn->value.function.actual = actual_arglist;
+
+  /* Set the end of the reference to the call to len_trim.  */
+
+  ref->u.ss.end = fcn;
+  gcc_assert (*rr == NULL);
+  *rr = ref;
+  return true;
 }
 
 #define WALK_SUBEXPR(NODE) \