Re: [patch, fortran] Load scalar intent-in variables at the beginning of procedures

[Thomas Koenig <tkoenig@netcologne.de>]

[-- Attachment #1: Type: text/plain, Size: 1427 bytes --]

Hello world,

here is an update to the patch.

I have now included variables where the user did not specify INTENT(IN)
by checking that the dummy variables to be replaced by temporaries
are not, indeed, assigned a value. This also includes being passed
as an actual argument to a non-INTENT(IN) dummy argument.

Extending this led to being able to catch a few more bugs.

I have addes one test case to check where the new temporaries are added.

Regression-tested. The only change I see in the testsuite now is

XPASS: gfortran.dg/goacc/kernels-loop-n.f95   -O   scan-tree-dump-times 
parloops1 "(?n)__attribute__\\(\\(oacc kernels parallelized, oacc 
function \\(, , \\), oacc kernels, omp target entrypoint\\)\\)" 1

So, OK for trunk?

Regards

	Thomas

2019-11-11  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/67202
	* dump-parse-tree.c (debug): Add for gfc_namespace.
	(show_code_node): Add INIT_ on dumping EXEC_INIT_ASSIGN.
	* frontent-passes.c (replace_intent_in): Add prototype.  New
	function.
	(optimize_namespace): Call it.
	(sym_replacement): New struct.
	(defined_code_callback): New function.
	(defined_expr_callback): New function.
	(replace_symbol_in_expr): New function.

2019-11-11  Thomas Koenig  <tkoenig@gcc.gnu.org>

	PR fortran/67202
	* gfortran.dg/intent_optimize_3.f90: New test.
	* gfortran.dg/intent_optimize_4.f90: New test.
	* gfortran.dg/pr26246_2.f90: Add -fno-frontend-optimize to flags.



[-- Attachment #2: p10.diff --]
[-- Type: text/x-patch, Size: 11580 bytes --]

Index: fortran/dump-parse-tree.c
===================================================================
--- fortran/dump-parse-tree.c	(Revision 278025)
+++ fortran/dump-parse-tree.c	(Arbeitskopie)
@@ -57,6 +57,15 @@ static void show_attr (symbol_attribute *, const c
 /* Allow dumping of an expression in the debugger.  */
 void gfc_debug_expr (gfc_expr *);
 
+void debug (gfc_namespace *ns)
+{
+  FILE *tmp = dumpfile;
+  dumpfile = stderr;
+  show_namespace (ns);
+  fputc ('\n', dumpfile);
+  dumpfile = tmp;
+}
+
 void debug (symbol_attribute *attr)
 {
   FILE *tmp = dumpfile;
@@ -1889,6 +1898,9 @@ show_code_node (int level, gfc_code *c)
       break;
 
     case EXEC_INIT_ASSIGN:
+      fputs ("INIT_", dumpfile);
+      /* Fallthrough */
+
     case EXEC_ASSIGN:
       fputs ("ASSIGN ", dumpfile);
       show_expr (c->expr1);
Index: fortran/frontend-passes.c
===================================================================
--- fortran/frontend-passes.c	(Revision 278025)
+++ fortran/frontend-passes.c	(Arbeitskopie)
@@ -57,6 +57,7 @@ static int call_external_blas (gfc_code **, int *,
 static int matmul_temp_args (gfc_code **, int *,void *data);
 static int index_interchange (gfc_code **, int*, void *);
 static bool is_fe_temp (gfc_expr *e);
+static void replace_intent_in (gfc_namespace *);
 
 #ifdef CHECKING_P
 static void check_locus (gfc_namespace *);
@@ -1467,6 +1468,7 @@ optimize_namespace (gfc_namespace *ns)
 
   if (flag_frontend_optimize)
     {
+      replace_intent_in (ns);
       gfc_code_walker (&ns->code, simplify_io_impl_do, dummy_expr_callback, NULL);
       gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL);
       gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL);
@@ -4969,7 +4971,7 @@ gfc_expr_walker (gfc_expr **e, walk_expr_fn_t expr
 	    if ((*e)->expr_type != EXPR_ARRAY)
 	      break;
 
-	    /* Fall through to the variable case in order to walk the
+ 	    /* Fall through to the variable case in order to walk the
 	       reference.  */
 	    gcc_fallthrough ();
 
@@ -5503,3 +5505,330 @@ gfc_check_externals (gfc_namespace *ns)
 
   gfc_errors_to_warnings (false);
 }
+
+/*  For scalar INTENT(IN) variables or for variables where we know
+    their value is not changed, we can replace them by an auxiliary
+    variable whose value is set on procedure entry.  */
+
+typedef struct sym_replacement
+{
+  gfc_symbol *original;
+  gfc_symtree *replacement_symtree;
+  bool referenced;
+
+} sym_replace;
+
+/* Callback function - replace expression if possible, and set
+   sr->referenced if this was done (so we know we need to generate
+   the assignment statement).  */
+
+static int
+replace_symbol_in_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+			void *data)
+{
+  gfc_expr *expr = *e;
+  sym_replacement *sr;
+
+  if (expr->expr_type != EXPR_VARIABLE || expr->symtree == NULL)
+    return 0;
+
+  sr = (sym_replacement *) data;
+
+  if (expr->symtree->n.sym == sr->original)
+    {
+      expr->symtree = sr->replacement_symtree;
+      sr->referenced = true;
+    }
+
+  return 0;
+}
+
+/* Callback to check if the symbol passed as data could be redefined.
+   Return 1 if this is the case.  */
+
+#define CHECK_TAG(member,tag)						\
+      do 								\
+	{ 								\
+	  if (co->ext.member->tag && co->ext.member->tag->symtree	\
+	      && co->ext.member->tag->symtree->n.sym == sym)		\
+	  return 1;							\
+	} while (0)
+
+static gfc_exec_op last_readwrite;
+
+/* Callback to determine if the symbol is defined somewhere for a
+   gfc_code.  Passing an argument to a subroutine as an argument
+   which is not an INTENT(IN) counts as being modified.  */
+
+static int
+defined_code_callback (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+		      void *data)
+{
+  gfc_code *co = *c;
+  gfc_symbol *sym;
+  gfc_formal_arglist *f;
+  gfc_actual_arglist *a;
+
+  sym = (gfc_symbol *) data;
+
+  switch (co->op)
+    {
+    case EXEC_IOLENGTH:
+      last_readwrite = EXEC_IOLENGTH;
+      /* Fall through.  */
+    case EXEC_ASSIGN:
+    case EXEC_LABEL_ASSIGN:
+      if (co->expr1->symtree->n.sym == sym)
+	return 1;
+      break;
+
+    case EXEC_OPEN:
+      CHECK_TAG (open, iostat);
+      CHECK_TAG (open, iomsg);
+      CHECK_TAG (open, newunit);
+      break;
+      
+    case EXEC_CLOSE:
+      CHECK_TAG (close, iostat);
+      CHECK_TAG (close, iomsg);
+      break;
+
+    case EXEC_BACKSPACE:
+    case EXEC_ENDFILE:
+    case EXEC_REWIND:
+    case EXEC_FLUSH:
+      CHECK_TAG (filepos, iostat);
+      CHECK_TAG (filepos, iomsg);
+      break;
+
+    case EXEC_INQUIRE:
+      CHECK_TAG (inquire, iomsg);
+      CHECK_TAG (inquire, iostat);
+      CHECK_TAG (inquire, exist);
+      CHECK_TAG (inquire, opened);
+      CHECK_TAG (inquire, number);
+      CHECK_TAG (inquire, named);
+      CHECK_TAG (inquire, name);
+      CHECK_TAG (inquire, access);
+      CHECK_TAG (inquire, sequential);
+      CHECK_TAG (inquire, direct);
+      CHECK_TAG (inquire, form);
+      CHECK_TAG (inquire, formatted);
+      CHECK_TAG (inquire, unformatted);
+      CHECK_TAG (inquire, recl);
+      CHECK_TAG (inquire, nextrec);
+      CHECK_TAG (inquire, blank);
+      CHECK_TAG (inquire, position);
+      CHECK_TAG (inquire, action);
+      CHECK_TAG (inquire, read);
+      CHECK_TAG (inquire, write);
+      CHECK_TAG (inquire, readwrite);
+      CHECK_TAG (inquire, delim);
+      CHECK_TAG (inquire, encoding);
+      CHECK_TAG (inquire, pad);
+      CHECK_TAG (inquire, iolength);
+      CHECK_TAG (inquire, convert);
+      CHECK_TAG (inquire, strm_pos);
+      CHECK_TAG (inquire, asynchronous);
+      CHECK_TAG (inquire, decimal);
+      CHECK_TAG (inquire, pending);
+      CHECK_TAG (inquire, id);
+      CHECK_TAG (inquire, sign);
+      CHECK_TAG (inquire, size);
+      CHECK_TAG (inquire, round);
+      break;
+
+    case EXEC_WAIT:
+      CHECK_TAG (wait, iostat);
+      CHECK_TAG (wait, iomsg);
+      break;
+
+    case EXEC_READ:
+      last_readwrite = EXEC_READ;
+      CHECK_TAG (dt, iostat);
+      CHECK_TAG (dt, iomsg);
+      CHECK_TAG (dt, id);
+      break;
+
+    case EXEC_WRITE:
+      last_readwrite = EXEC_WRITE;
+      CHECK_TAG (dt, iostat);
+      CHECK_TAG (dt, iomsg);
+      CHECK_TAG (dt, id);
+      break;
+
+    case EXEC_DT_END:
+      last_readwrite = EXEC_NOP;
+      break;
+
+    case EXEC_TRANSFER:
+      if (last_readwrite == EXEC_READ && co->expr1
+	  && co->expr1->expr_type == EXPR_VARIABLE
+	  && co->expr1->symtree && co->expr1->symtree->n.sym == sym)
+	return 1;
+      break;
+
+    case EXEC_DO:
+      if (co->ext.iterator && co->ext.iterator->var->symtree->n.sym == sym)
+	return 1;
+      break;
+
+    case EXEC_CALL:
+      if (co->resolved_sym == NULL)
+	return 1;
+
+      f = gfc_sym_get_dummy_args (co->resolved_sym);
+      for (a = co->ext.actual; a; a = a->next)
+	{
+	  if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == sym)
+	    {
+	      if (f == NULL || f->sym == NULL)
+		return 1;
+
+	      if (f->sym->attr.intent != INTENT_IN)
+		return 1;
+	    }
+	  if (f)
+	    f = f->next;
+	}
+      break;
+
+    default:
+      break;
+    }
+  return 0;
+
+}
+
+#undef CHECK_TAG
+
+/* Callback to determine if the symbol is defined as an argument to a
+   function.  Passing to a function as an argument which is not an
+   INTENT(IN) counts as being modified.  */
+
+static int
+defined_expr_callback (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+		       void *data)
+{
+  gfc_expr *expr = *e;
+  gfc_symbol *sym;
+  gfc_formal_arglist *f;
+  gfc_actual_arglist *a;
+
+  if (expr->expr_type != EXPR_FUNCTION || expr->value.function.isym)
+    return 0;
+
+  sym = (gfc_symbol *) data;
+  f = gfc_sym_get_dummy_args (expr->symtree->n.sym);
+
+  for (a = expr->value.function.actual; a ; a = a->next)
+    {
+      if (a->expr && a->expr->symtree && a->expr->symtree->n.sym == sym)
+	{
+	  if (f == NULL || f->sym == NULL)
+	    return 1;
+
+	  if (f->sym->attr.intent != INTENT_IN)
+	    return 1;
+	}
+      if (f)
+	f = f->next;
+    }
+  return 0;
+}
+
+/* Replace INTENT(IN) scalar variables by assigning their values to
+   temporary variables.  We really only want to use this for the
+   simplest cases, all the fancy stuff is excluded.  */
+
+static void
+replace_intent_in (gfc_namespace *ns)
+{
+  gfc_formal_arglist *f;
+  gfc_namespace *ns_c;
+  gfc_code **c;
+
+  if (ns == NULL || ns->proc_name == NULL || gfc_elemental (ns->proc_name)
+      || ns->proc_name->attr.entry_master)
+    return;
+
+  for (f = ns->proc_name->formal; f; f = f->next)
+    {
+      if (f->sym == NULL || f->sym->attr.dimension || f->sym->attr.allocatable
+	  || f->sym->attr.optional || f->sym->attr.pointer
+	  || f->sym->attr.codimension || f->sym->attr.value
+	  || f->sym->attr.proc_pointer || f->sym->attr.target
+	  || f->sym->attr.asynchronous || f->sym->attr.volatile_
+	  || f->sym->attr.procedure
+	  || f->sym->ts.type == BT_CHARACTER || f->sym->ts.type == BT_DERIVED
+	  || f->sym->ts.type == BT_CLASS || f->sym->ts.type == BT_UNKNOWN
+	  || f->sym->attr.intent == INTENT_OUT)
+	continue;
+
+      if (f->sym->attr.intent == INTENT_IN
+	  || gfc_code_walker (&ns->code, defined_code_callback,
+			      defined_expr_callback, (void *) f->sym) == 0)
+	{
+	  gfc_symtree *symtree;
+	  gfc_symbol *replacement;
+	  sym_replace sr;
+
+	  char name[GFC_MAX_SYMBOL_LEN + 1];
+	  snprintf (name, GFC_MAX_SYMBOL_LEN, "__dummy_%d_%s", var_num++,
+		    f->sym->name);
+
+	  if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
+	    gcc_unreachable ();
+
+	  replacement = symtree->n.sym;
+	  replacement->ts = f->sym->ts;
+	  replacement->attr.flavor = FL_VARIABLE;
+	  replacement->attr.fe_temp = 1;
+	  replacement->attr.referenced = 1;
+	  replacement->declared_at = f->sym->declared_at;
+	  gfc_commit_symbol (replacement);
+
+	  sr.original = f->sym;
+	  sr.replacement_symtree = symtree;
+	  sr.referenced = false;
+
+	  /* Skip any INIT_ASSIGN statements at the beginning.  */
+	  for (c = &ns->code; *c != NULL && (*c)->op == EXEC_INIT_ASSIGN;
+	       c = &(*c)->next)
+	    ;
+
+	  gfc_code_walker (c, gfc_dummy_code_callback,
+			   replace_symbol_in_expr, (void *) &sr);
+
+	  for (ns_c = ns->contained; ns_c != NULL; ns_c = ns_c->sibling)
+	    {
+	      gfc_code **c_c;
+	      for (c_c = &ns_c->code; *c_c != NULL && (*c_c)->op == EXEC_INIT_ASSIGN;
+		   c_c = &(*c_c)->next)
+		;
+
+	      gfc_code_walker (&ns_c->code, gfc_dummy_code_callback,
+			       replace_symbol_in_expr, (void *) &sr);
+	    }
+
+	  if (sr.referenced)
+	    {
+	      gfc_code *n;
+	      gfc_symtree *formal_symtree;
+
+	      /* Generate statement __tmp_42_foo = foo .   */
+	      n = XCNEW (gfc_code);
+	      n->op = EXEC_ASSIGN;
+	      n->expr1 = gfc_lval_expr_from_sym (replacement);
+	      n->expr1->where = f->sym->declared_at;
+	      formal_symtree = gfc_find_symtree (ns->sym_root, f->sym->name);
+	      n->expr2 = gfc_get_variable_expr (formal_symtree);
+	      n->expr2->where = f->sym->declared_at;
+	      n->loc = f->sym->declared_at;
+
+	      n->next = (*c);
+	      (*c) = n;
+	    }
+	}
+    }
+}
Index: testsuite/gfortran.dg/pr26246_2.f90
===================================================================
--- testsuite/gfortran.dg/pr26246_2.f90	(Revision 278025)
+++ testsuite/gfortran.dg/pr26246_2.f90	(Arbeitskopie)
@@ -1,5 +1,5 @@
 ! PR fortran/26246
-! { dg-options "-fdump-tree-original -fno-automatic" }
+! { dg-options "-fno-frontend-optimize -fdump-tree-original -fno-automatic" }
 ! { dg-do compile }
 
 subroutine foo(string, n)

[-- Attachment #3: intent_optimize_4.f90 --]
[-- Type: text/x-fortran, Size: 1393 bytes --]

! { dg-do compile }
! { dg-options "-fdump-tree-original -ffrontend-optimize" }

! PR 67202 Check different situations for when a local copy of an
! argument passed by references should be made.
module x
  implicit none
contains
  subroutine foo (a, b, c, d, e, f, g, h, ios, recl)
    real :: a, b, c, d, e, f, g, h
    integer :: n, ios, recl
    read (*,*, iostat=ios) a
    write (*,*) b
    inquire (unit=10, recl=recl)
    call bar (c, d)
    write (*,*) baz(e, g), sin(f)
  end subroutine foo
  subroutine bar(x, y)
    real, intent(in) :: x
    real :: y
  end subroutine bar
  real function baz(xx,yy)
    real, intent(inout) :: xx
    real, intent(in) :: yy
    baz = 42.
    xx = yy + 1.
  end function baz
end module x
! { dg-final { scan-tree-dump-times "__dummy_\[0-9\]_a" 0 "original" } }
! { dg-final { scan-tree-dump-times "__dummy_\[0-9\]_ios" 0 "original" } }
! { dg-final { scan-tree-dump-times "__dummy_\[0-9\]_b" 3 "original" } }
! { dg-final { scan-tree-dump-times "__dummy_\[0-9\]_recl" 0 "original" } }
! { dg-final { scan-tree-dump-times "__dummy_\[0-9\]_c" 3 "original" } }
! { dg-final { scan-tree-dump-times "__dummy_\[0-9\]_d" 0 "original" } }
! { dg-final { scan-tree-dump-times "__dummy_\[0-9\]_e" 0 "original" } }
! { dg-final { scan-tree-dump-times "__dummy_\[0-9\]_f" 3 "original" } }
! { dg-final { scan-tree-dump-times "__dummy_\[0-9\]_g" 3 "original" } }

[-- Attachment #4: intent_optimize_3.f90 --]
[-- Type: text/x-fortran, Size: 486 bytes --]

! { dg-do compile }
! { dg-options "-fdump-tree-original -ffrontend-optimize" }
! PR 67202 - load INTENT(IN) scalars to a variable.
module x
contains
  subroutine foo (i, j, k1, k2)
    integer, intent(in) :: i,j
    integer, intent(out) :: k1, k2
    k1 = i + j
    block
      k2 = i
    end block      
  end subroutine foo
end module x
! { dg-final { scan-tree-dump-times "__dummy_\[0-9\]_i" 4 "original" } }
! { dg-final { scan-tree-dump-times "__dummy_\[0-9\]_j" 3 "original" } }