Hello world,
the attached patch is a front-end optimization which replaces multiple
calls to a function with identical argument lists with an assignment to
a temporary variable, and then uses that variable in the original
expression.
AFAIK, this is permitted by the Fortran standard because such functions
have side effects, the program is illegal.
OK for trunk, now that it has reopened?
Thomas
2010-03-14 Thomas Koenig <tkoe...@gcc.gnu.org>
PR fortran/22572
* frontend_passes (expr_array): New static variable.
(expr_size): Likewise.
(expr_count): Likewise.
(current_code): Likewise.
(current_ns): Likewise.
(gfc_run_passes): Allocate and free space for expressions.
(compare_functions): New function.
(cfe_expr): New function.
(create_var): New function.
(cfc_expr_0): New function.
(cfe_code): New function.
(optimize_namespace): Invoke gfc_code_walker with cfe_code
and cfe_expr_0.
2010-03-14 Thomas Koenig <tkoe...@gcc.gnu.org>
PR fortran/22572
* gfortran.dg/function_optimize_1.f90: New test.
! { dg-do compile }
! { dg-options "-O -fdump-tree-original" }
program main
implicit none
real, dimension(2,2) :: a, b, c, d
character(60) :: line
real, external :: ext_func
real :: x
data a /2., 3., 5., 7./
data b /11., 13., 17., 23./
write (unit=line, fmt='(4F7.2)') matmul(a,b) + matmul(a,b)
d = sin(a) + cos(a) + sin(a) + cos(a)
x = ext_func(a) + 23 + ext_func(a)
end program main
! { dg-final { scan-tree-dump-times "matmul_r4" 1 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_sinf" 1 "original" } }
! { dg-final { scan-tree-dump-times "__builtin_cosf" 1 "original" } }
! { dg-final { scan-tree-dump-times "ext_func" 1 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
Index: frontend-passes.c
===================================================================
--- frontend-passes.c (Revision 170960)
+++ frontend-passes.c (Arbeitskopie)
@@ -40,6 +40,21 @@ static bool optimize_trim (gfc_expr *);
static int count_arglist;
+/* Pointer to an array of gfc_expr ** we operate on, plus its size
+ and counter. */
+
+static gfc_expr ***expr_array;
+static int expr_size, expr_count;
+
+/* Pointer to the gfc_code we currently work on - to be able to insert
+ a statement before. */
+
+static gfc_code **current_code;
+
+/* The namespace we are currently dealing with. */
+
+gfc_namespace *current_ns;
+
/* Entry point - run all passes for a namespace. So far, only an
optimization pass is run. */
@@ -48,9 +63,16 @@ gfc_run_passes (gfc_namespace *ns)
{
if (optimize)
{
+ expr_size = 20;
+ expr_array = XNEWVEC(gfc_expr **, expr_size);
+
optimize_namespace (ns);
if (gfc_option.dump_fortran_optimized)
gfc_dump_parse_tree (ns, stdout);
+
+ /* FIXME: The following should be XDELETEVEC(expr_array);
+ but we cannot do that because it depends on free. */
+ gfc_free (expr_array);
}
}
@@ -106,11 +128,222 @@ optimize_expr (gfc_expr **e, int *walk_subtrees AT
return 0;
}
+/* Compare two functions for equality. We could use gfc_dep_compare_expr
+ except that we also consider impure functions equal, because anybody
+ changing the return value of the function within an expression would
+ violate the Fortran standard. */
+
+static bool
+compare_functions (gfc_expr **ep1, gfc_expr **ep2)
+{
+ gfc_expr *e1, *e2;
+
+ e1 = *ep1;
+ e2 = *ep2;
+
+ if (e1->expr_type != EXPR_FUNCTION || e2->expr_type != EXPR_FUNCTION)
+ return false;
+
+ if ((e1->value.function.esym && e2->value.function.esym
+ && e1->value.function.esym == e2->value.function.esym)
+ || (e1->value.function.isym && e2->value.function.isym
+ && e1->value.function.isym == e2->value.function.isym))
+ {
+ gfc_actual_arglist *args1, *args2;
+
+ args1 = e1->value.function.actual;
+ args2 = e2->value.function.actual;
+
+ /* Compare the argument lists for equality. */
+ while (args1 && args2)
+ {
+ /* Bitwise xor, since C has no non-bitwise xor operator. */
+ if ((args1->expr == NULL) ^ (args2->expr == NULL))
+ return false;
+
+ if (args1->expr != NULL && args2->expr != NULL
+ && gfc_dep_compare_expr (args1->expr, args2->expr) != 0)
+ return false;
+
+ args1 = args1->next;
+ args2 = args2->next;
+ }
+ return args1 == NULL && args2 == NULL;
+ }
+ else
+ return false;
+
+}
+
+/* Callback function for gfc_expr_walker, called from cfe_expr_0. Put all
+ eligible function expressions into expr_array. We can't do allocatable
+ functions. */
+
+static int
+cfe_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ if ((*e)->expr_type != EXPR_FUNCTION)
+ return 0;
+
+ /* We don't do character functions (yet). */
+ if ((*e)->ts.type == BT_CHARACTER)
+ return 0;
+
+ /* If we don't know the shape at compile time, we do not create a temporary
+ variable to hold the intermediate result. FIXME: Change this later when
+ allocation on assignment works for intrinsics. */
+
+ if ((*e)->rank > 0 && (*e)->shape == NULL)
+ return 0;
+
+ if ((*e)->value.function.esym
+ && (*e)->value.function.esym->attr.allocatable)
+ return 0;
+
+ if ((*e)->value.function.isym
+ && (*e)->value.function.isym->id == GFC_ISYM_CONVERSION)
+ return 0;
+
+ if (expr_count >= expr_size)
+ {
+ expr_size += expr_size;
+ expr_array = XRESIZEVEC(gfc_expr **, expr_array, expr_size);
+ }
+ expr_array[expr_count] = e;
+ expr_count ++;
+ return 0;
+}
+
+/* Returns a new expression (a variable) to be used in place of the old one,
+ with an an assignment statement before the current statement to set
+ the value of the variable. */
+
+ gfc_expr *create_var(gfc_expr *);
+
+gfc_expr*
+create_var (gfc_expr * e)
+{
+ char name[GFC_MAX_SYMBOL_LEN +1];
+ static int num = 1;
+ gfc_symtree *symtree;
+ gfc_symbol *symbol;
+ gfc_expr *result;
+ gfc_code *n;
+ int i;
+
+ sprintf(name, "__var_%d",num++);
+ if (gfc_get_sym_tree (name, current_ns, &symtree, false) != 0)
+ gcc_unreachable ();
+
+ symbol = symtree->n.sym;
+ symbol->ts = e->ts;
+ symbol->as = gfc_get_array_spec ();
+ symbol->as->rank = e->rank;
+ symbol->as->type = AS_EXPLICIT;
+ for (i=0; i<e->rank; i++)
+ {
+ gfc_expr *p, *q;
+
+ p = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &(e->where));
+ mpz_set_si (p->value.integer, 1);
+ symbol->as->lower[i] = p;
+
+ q = gfc_get_constant_expr (BT_INTEGER, gfc_index_integer_kind,
+ &(e->where));
+ mpz_set (q->value.integer, e->shape[i]);
+ symbol->as->upper[i] = q;
+ }
+
+ symbol->attr.flavor = FL_VARIABLE;
+ symbol->attr.referenced = 1;
+ symbol->attr.dimension = e->rank > 0;
+ gfc_commit_symbol (symbol);
+
+ result = gfc_get_expr ();
+ result->expr_type = EXPR_VARIABLE;
+ result->ts = e->ts;
+ result->rank = e->rank;
+ result->shape = gfc_copy_shape (e->shape, e->rank);
+ result->symtree = symtree;
+ result->where = e->where;
+ if (e->rank > 0)
+ {
+ result->ref = gfc_get_ref ();
+ result->ref->type = REF_ARRAY;
+ result->ref->u.ar.type = AR_FULL;
+ result->ref->u.ar.where = e->where;
+ result->ref->u.ar.as = symbol->as;
+ }
+
+ /* Generate the new assignment. */
+ n = XCNEW (gfc_code);
+ n->op = EXEC_ASSIGN;
+ n->loc = (*current_code)->loc;
+ n->next = *current_code;
+ n->expr1 = gfc_copy_expr (result);
+ n->expr2 = e;
+ *current_code = n;
+
+ return result;
+}
+
+/* Callback function for the code walker for doing common function
+ elimination. This builds up the list of functions in the expression
+ and goes through them to detect duplicates, which it then replaces
+ by variables. */
+
+static int
+cfe_expr_0 (gfc_expr **e, int *walk_subtrees,
+ void *data ATTRIBUTE_UNUSED)
+{
+ int i,j;
+ gfc_expr *newvar;
+
+ expr_count = 0;
+ gfc_expr_walker (e, cfe_expr, NULL);
+ /* Walk backwards through all the functions to make sure we
+ catch the leaf functions first. */
+ for (i=expr_count-1; i>=1; i--)
+ {
+ newvar = NULL;
+ for (j=i-1; j>=0; j--)
+ {
+ if (compare_functions(expr_array[i], expr_array[j]))
+ {
+ if (newvar == NULL)
+ newvar = create_var (*(expr_array[i]));
+ gfc_free (*(expr_array[j]));
+ *(expr_array[j]) = gfc_copy_expr (newvar);
+ }
+ }
+ if (newvar)
+ *(expr_array[i]) = newvar;
+ }
+
+ /* We did all the necessary walking in this function. */
+ *walk_subtrees = 0;
+ return 0;
+}
+
+static int
+cfe_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ current_code = c;
+ return 0;
+}
+
/* Optimize a namespace, including all contained namespaces. */
static void
optimize_namespace (gfc_namespace *ns)
{
+
+ current_ns = ns;
+
+ gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL);
gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL);
for (ns = ns->contained; ns; ns = ns->sibling)
