Re: [patch, fortran] Handling of .and. and .or. expressions

[Thomas Koenig <tkoenig at netcologne dot de>]

Hi Janus,

> I happen to hold the opinion that optimizing out a call to a pure 
> function may be reasonable if it does not influence the result of an 
> expression, but optimizing out an effectively impure function (i.e. one 
> with side effects) is not a good idea at any time, since such an 
> 'optimization' can drastically change the program flow and all numerical 
> results of a piece of code.

Well, I am of a different opinion, and so is the Fortran standard.

I think the compiler should strive to, in that order,

- conform to the language standard
- generate fast programs
- warn about features which may trip the user

In my patch, I have tried to do all three things at the same time, and
after this discussion, I still think that this is the right path
to follow.

So, here is an update on the patch, which also covers ALLOCATED.

Regression-tested. OK?

	Thomas

! { dg-do compile }
! { dg-additional-options "-Wsurprising -fdump-tree-original" }
! PR 85599 - check warning that impure function calls might be removed,
! and that logical expressions involving .and. and .or. will be
! reordered. 

MODULE M1
 TYPE T1
   LOGICAL :: T=.TRUE.
 END TYPE T1
CONTAINS
 SUBROUTINE S1(m)
   TYPE(T1), POINTER :: m
   TYPE(T1), ALLOCATABLE :: x
   IF (ASSOCIATED(m) .AND. m%T) THEN ! { dg-warning "does not guard expression" }
    WRITE(6,*) "X"
   ENDIF
   IF (ALLOCATED(x) .AND. x%T) THEN ! { dg-warning "does not guard expression" }
    WRITE(6,*) ""
   ENDIF
 END SUBROUTINE
END MODULE

module x
  logical :: flag = .true.
  integer :: count = 0
contains
  pure function f()
    logical :: f
    f = .true.
  end function f

  function g()
    logical :: g
    g = .false.
  end function g

  real function h()
     h = 1.2
     count = count + 1
  end function h
end module x

program main
  use x
  print *, g() .and. f() ! No warning, because g() follows all the rules of a pure function
  print *, f() .and. flag
  print *, h() > 1.0 .and. flag ! { dg-warning "might not be evaluated" }
  print *, h() < 1.0 .or. flag ! { dg-warning "might not be evaluated" }

end program main
! { dg-final { scan-tree-dump-times "flag &&" 2 "original" } }
! { dg-final { scan-tree-dump-times "flag \\|\\|" 1 "original" } }

Index: dump-parse-tree.c
===================================================================
--- dump-parse-tree.c	(Revision 261388)
+++ dump-parse-tree.c	(Arbeitskopie)
@@ -716,6 +716,8 @@ show_attr (symbol_attribute *attr, const char * mo
     fputs (" ELEMENTAL", dumpfile);
   if (attr->pure)
     fputs (" PURE", dumpfile);
+  if (attr->implicit_pure)
+    fputs (" IMPLICIT_PURE", dumpfile);
   if (attr->recursive)
     fputs (" RECURSIVE", dumpfile);
 
Index: resolve.c
===================================================================
--- resolve.c	(Revision 261388)
+++ resolve.c	(Arbeitskopie)
@@ -3807,7 +3807,43 @@ lookup_uop_fuzzy (const char *op, gfc_symtree *uop
   return gfc_closest_fuzzy_match (op, candidates);
 }
 
+/* Callback finding an impure function as an operand to an .and. or
+   .or.  expression.  Remember the last function warned about to
+   avoid double warnings when recursing.  */
 
+static int
+impure_function_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+			  void *data)
+{
+  gfc_expr *f = *e;
+  const char *name;
+  static gfc_expr *last = NULL;
+  bool *found = (bool *) data;
+
+  if (f->expr_type == EXPR_FUNCTION)
+    {
+      *found = 1;
+      if (f != last && !pure_function (f, &name))
+	{
+	  /* This could still be a function without side effects, i.e.
+	     implicit pure.  Do not warn for that case.  */
+	  if (f->symtree == NULL || f->symtree->n.sym == NULL
+	      || !gfc_implicit_pure (f->symtree->n.sym))
+	    {
+	      if (name)
+		gfc_warning (OPT_Wsurprising, "Function %qs at %L "
+			     "might not be evaluated", name, &f->where);
+	      else
+		gfc_warning (OPT_Wsurprising, "Function at %L "
+			     "might not be evaluated", &f->where);
+	    }
+	}
+      last = f;
+    }
+
+  return 0;
+}
+
 /* Resolve an operator expression node.  This can involve replacing the
    operation with a user defined function call.  */
 
@@ -3910,6 +3946,8 @@ resolve_operator (gfc_expr *e)
     case INTRINSIC_NEQV:
       if (op1->ts.type == BT_LOGICAL && op2->ts.type == BT_LOGICAL)
 	{
+	  bool dont_move = false;
+
 	  e->ts.type = BT_LOGICAL;
 	  e->ts.kind = gfc_kind_max (op1, op2);
 	  if (op1->ts.kind < e->ts.kind)
@@ -3916,6 +3954,67 @@ resolve_operator (gfc_expr *e)
 	    gfc_convert_type (op1, &e->ts, 2);
 	  else if (op2->ts.kind < e->ts.kind)
 	    gfc_convert_type (op2, &e->ts, 2);
+
+	  if (e->value.op.op == INTRINSIC_AND || e->value.op.op == INTRINSIC_OR)
+	    {
+	      bool op1_f, op2_f;
+
+	      op1_f = false;
+	      op2_f = false;
+	      gfc_expr_walker (&op1, impure_function_callback, &op1_f);
+	      gfc_expr_walker (&op2, impure_function_callback, &op2_f);
+
+	      /* Some people code which depends on the short-circuiting that
+		 Fortran does not provide, such as
+
+		 if (associated(m) .and. m%t) then
+
+		 So, warn about this idiom. However, avoid breaking
+		 it on purpose.  */
+
+	      if (op1->expr_type == EXPR_FUNCTION && op1->value.function.isym)
+		{
+		  gfc_expr *e;
+		  bool warn = false;
+		  gfc_isym_id id;
+
+		  id = op1->value.function.isym->id;
+		  if (id == GFC_ISYM_ASSOCIATED)
+		    {
+		      e = op1->value.function.actual->expr;
+		      warn = op1->value.function.actual->next->expr == NULL;
+		    }
+		  else if (id == GFC_ISYM_ALLOCATED)
+		    {
+		      e = op1->value.function.actual->expr;
+		      warn = true;
+		    }
+
+		  if (warn && gfc_check_dependency (e, op2, true))
+		    {
+		      gfc_warning (OPT_Wsurprising, "%qs function call at "
+				   "%L does not guard expression at %L",
+				   op1->value.function.isym->name,
+				   &op1->where, &op2->where);
+		      dont_move = true;
+		    }
+		}
+
+	      /* A bit of optimization: Transfer if (f(x) .and. flag)
+		 into if (flag .and. f(x)), to save evaluation of a
+		 function.  The middle end should be capable of doing
+		 this with a TRUTH_AND_EXPR, but it currently does not do
+		 so. See PR 85599.  */
+
+	      if (!dont_move && op1_f && !op2_f)
+		{
+		  e->value.op.op1 = op2;
+		  e->value.op.op2 = op1;
+		  op1 = e->value.op.op1;
+		  op2 = e->value.op.op2;
+		}
+	    }
+
 	  break;
 	}