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 <tkoe...@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 <tkoe...@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.
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)
! { 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" } }
! { 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" } }
