/* Pass manager for Fortran front end.
- Copyright (C) 2010 Free Software Foundation, Inc.
+ Copyright (C) 2010-2014 Free Software Foundation, Inc.
Contributed by Thomas König.
This file is part of GCC.
#include "config.h"
#include "system.h"
+#include "coretypes.h"
#include "gfortran.h"
#include "arith.h"
#include "flags.h"
+#include "dependency.h"
+#include "constructor.h"
+#include "opts.h"
/* Forward declarations. */
static void strip_function_call (gfc_expr *);
+static void optimize_namespace (gfc_namespace *);
static void optimize_assignment (gfc_code *);
-static void optimize_expr_0 (gfc_expr *);
-static bool optimize_expr (gfc_expr *);
static bool optimize_op (gfc_expr *);
-static bool optimize_equality (gfc_expr *, bool);
-static void optimize_code (gfc_code *);
-static void optimize_code_node (gfc_code *);
-static void optimize_actual_arglist (gfc_actual_arglist *);
+static bool optimize_comparison (gfc_expr *, gfc_intrinsic_op);
+static bool optimize_trim (gfc_expr *);
+static bool optimize_lexical_comparison (gfc_expr *);
+static void optimize_minmaxloc (gfc_expr **);
+static bool is_empty_string (gfc_expr *e);
+static void doloop_warn (gfc_namespace *);
+static void optimize_reduction (gfc_namespace *);
+static int callback_reduction (gfc_expr **, int *, void *);
-/* Entry point - run all passes for a namespace. So far, only an
- optimization pass is run. */
+/* How deep we are inside an argument list. */
+
+static int count_arglist;
+
+/* Vector of gfc_expr ** we operate on. */
+
+static vec<gfc_expr **> expr_array;
+
+/* Pointer to the gfc_code we currently work on - to be able to insert
+ a block before the statement. */
+
+static gfc_code **current_code;
+
+/* Pointer to the block to be inserted, and the statement we are
+ changing within the block. */
+
+static gfc_code *inserted_block, **changed_statement;
+
+/* The namespace we are currently dealing with. */
+
+static gfc_namespace *current_ns;
+
+/* If we are within any forall loop. */
+
+static int forall_level;
+
+/* Keep track of whether we are within an OMP workshare. */
+
+static bool in_omp_workshare;
+
+/* Keep track of iterators for array constructors. */
+
+static int iterator_level;
+
+/* Keep track of DO loop levels. */
+
+static vec<gfc_code *> doloop_list;
+
+static int doloop_level;
+
+/* Vector of gfc_expr * to keep track of DO loops. */
+
+struct my_struct *evec;
+
+/* Keep track of association lists. */
+
+static bool in_assoc_list;
+
+/* Entry point - run all passes for a namespace. */
void
-gfc_run_passes (gfc_namespace * ns)
+gfc_run_passes (gfc_namespace *ns)
{
- if (optimize)
- optimize_code (ns->code);
+
+ /* Warn about dubious DO loops where the index might
+ change. */
+
+ doloop_level = 0;
+ doloop_warn (ns);
+ doloop_list.release ();
+
+ if (gfc_option.flag_frontend_optimize)
+ {
+ optimize_namespace (ns);
+ optimize_reduction (ns);
+ if (gfc_option.dump_fortran_optimized)
+ gfc_dump_parse_tree (ns, stdout);
+
+ expr_array.release ();
+ }
}
-static void
-optimize_code (gfc_code *c)
+/* Callback for each gfc_code node invoked through gfc_code_walker
+ from optimize_namespace. */
+
+static int
+optimize_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
{
- for (; c; c = c->next)
- optimize_code_node (c);
+
+ gfc_exec_op op;
+
+ op = (*c)->op;
+
+ if (op == EXEC_CALL || op == EXEC_COMPCALL || op == EXEC_ASSIGN_CALL
+ || op == EXEC_CALL_PPC)
+ count_arglist = 1;
+ else
+ count_arglist = 0;
+
+ current_code = c;
+ inserted_block = NULL;
+ changed_statement = NULL;
+
+ if (op == EXEC_ASSIGN)
+ optimize_assignment (*c);
+ return 0;
}
+/* Callback for each gfc_expr node invoked through gfc_code_walker
+ from optimize_namespace. */
-/* Do the optimizations for a code node. */
+static int
+optimize_expr (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ bool function_expr;
-static void
-optimize_code_node (gfc_code *c)
+ if ((*e)->expr_type == EXPR_FUNCTION)
+ {
+ count_arglist ++;
+ function_expr = true;
+ }
+ else
+ function_expr = false;
+
+ if (optimize_trim (*e))
+ gfc_simplify_expr (*e, 0);
+
+ if (optimize_lexical_comparison (*e))
+ gfc_simplify_expr (*e, 0);
+
+ if ((*e)->expr_type == EXPR_OP && optimize_op (*e))
+ gfc_simplify_expr (*e, 0);
+
+ if ((*e)->expr_type == EXPR_FUNCTION && (*e)->value.function.isym)
+ switch ((*e)->value.function.isym->id)
+ {
+ case GFC_ISYM_MINLOC:
+ case GFC_ISYM_MAXLOC:
+ optimize_minmaxloc (e);
+ break;
+ default:
+ break;
+ }
+
+ if (function_expr)
+ count_arglist --;
+
+ return 0;
+}
+
+/* Auxiliary function to handle the arguments to reduction intrnisics. If the
+ function is a scalar, just copy it; otherwise returns the new element, the
+ old one can be freed. */
+
+static gfc_expr *
+copy_walk_reduction_arg (gfc_constructor *c, gfc_expr *fn)
{
+ gfc_expr *fcn, *e = c->expr;
- gfc_forall_iterator *fa;
- gfc_code *d;
- gfc_alloc *a;
+ fcn = gfc_copy_expr (e);
+ if (c->iterator)
+ {
+ gfc_constructor_base newbase;
+ gfc_expr *new_expr;
+ gfc_constructor *new_c;
+
+ newbase = NULL;
+ new_expr = gfc_get_expr ();
+ new_expr->expr_type = EXPR_ARRAY;
+ new_expr->ts = e->ts;
+ new_expr->where = e->where;
+ new_expr->rank = 1;
+ new_c = gfc_constructor_append_expr (&newbase, fcn, &(e->where));
+ new_c->iterator = c->iterator;
+ new_expr->value.constructor = newbase;
+ c->iterator = NULL;
+
+ fcn = new_expr;
+ }
- switch (c->op)
+ if (fcn->rank != 0)
{
- case EXEC_ASSIGN:
- optimize_assignment (c);
- break;
+ gfc_isym_id id = fn->value.function.isym->id;
+
+ if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
+ fcn = gfc_build_intrinsic_call (current_ns, id,
+ fn->value.function.isym->name,
+ fn->where, 3, fcn, NULL, NULL);
+ else if (id == GFC_ISYM_ANY || id == GFC_ISYM_ALL)
+ fcn = gfc_build_intrinsic_call (current_ns, id,
+ fn->value.function.isym->name,
+ fn->where, 2, fcn, NULL);
+ else
+ gfc_internal_error ("Illegal id in copy_walk_reduction_arg");
+
+ fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
+ }
- case EXEC_CALL:
- case EXEC_ASSIGN_CALL:
- case EXEC_CALL_PPC:
- optimize_actual_arglist (c->ext.actual);
+ return fcn;
+}
+
+/* Callback function for optimzation of reductions to scalars. Transform ANY
+ ([f1,f2,f3, ...]) to f1 .or. f2 .or. f3 .or. ..., with ANY, SUM and PRODUCT
+ correspondingly. Handly only the simple cases without MASK and DIM. */
+
+static int
+callback_reduction (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_expr *fn, *arg;
+ gfc_intrinsic_op op;
+ gfc_isym_id id;
+ gfc_actual_arglist *a;
+ gfc_actual_arglist *dim;
+ gfc_constructor *c;
+ gfc_expr *res, *new_expr;
+ gfc_actual_arglist *mask;
+
+ fn = *e;
+
+ if (fn->rank != 0 || fn->expr_type != EXPR_FUNCTION
+ || fn->value.function.isym == NULL)
+ return 0;
+
+ id = fn->value.function.isym->id;
+
+ if (id != GFC_ISYM_SUM && id != GFC_ISYM_PRODUCT
+ && id != GFC_ISYM_ANY && id != GFC_ISYM_ALL)
+ return 0;
+
+ a = fn->value.function.actual;
+
+ /* Don't handle MASK or DIM. */
+
+ dim = a->next;
+
+ if (dim->expr != NULL)
+ return 0;
+
+ if (id == GFC_ISYM_SUM || id == GFC_ISYM_PRODUCT)
+ {
+ mask = dim->next;
+ if ( mask->expr != NULL)
+ return 0;
+ }
+
+ arg = a->expr;
+
+ if (arg->expr_type != EXPR_ARRAY)
+ return 0;
+
+ switch (id)
+ {
+ case GFC_ISYM_SUM:
+ op = INTRINSIC_PLUS;
break;
- case EXEC_ARITHMETIC_IF:
- optimize_expr_0 (c->expr1);
+ case GFC_ISYM_PRODUCT:
+ op = INTRINSIC_TIMES;
break;
- case EXEC_PAUSE:
- case EXEC_RETURN:
- case EXEC_ERROR_STOP:
- case EXEC_STOP:
- case EXEC_COMPCALL:
- optimize_expr_0 (c->expr1);
+ case GFC_ISYM_ANY:
+ op = INTRINSIC_OR;
break;
- case EXEC_SYNC_ALL:
- case EXEC_SYNC_MEMORY:
- case EXEC_SYNC_IMAGES:
- optimize_expr_0 (c->expr2);
+ case GFC_ISYM_ALL:
+ op = INTRINSIC_AND;
break;
- case EXEC_IF:
- d = c->block;
- optimize_expr_0 (d->expr1);
- optimize_code (d->next);
+ default:
+ return 0;
+ }
- for (d = d->block; d; d = d->block)
- {
- optimize_expr_0 (d->expr1);
+ c = gfc_constructor_first (arg->value.constructor);
- optimize_code (d->next);
- }
+ /* Don't do any simplififcation if we have
+ - no element in the constructor or
+ - only have a single element in the array which contains an
+ iterator. */
+ if (c == NULL)
+ return 0;
- break;
+ res = copy_walk_reduction_arg (c, fn);
- case EXEC_SELECT:
- case EXEC_SELECT_TYPE:
- d = c->block;
+ c = gfc_constructor_next (c);
+ while (c)
+ {
+ new_expr = gfc_get_expr ();
+ new_expr->ts = fn->ts;
+ new_expr->expr_type = EXPR_OP;
+ new_expr->rank = fn->rank;
+ new_expr->where = fn->where;
+ new_expr->value.op.op = op;
+ new_expr->value.op.op1 = res;
+ new_expr->value.op.op2 = copy_walk_reduction_arg (c, fn);
+ res = new_expr;
+ c = gfc_constructor_next (c);
+ }
- optimize_expr_0 (c->expr1);
+ gfc_simplify_expr (res, 0);
+ *e = res;
+ gfc_free_expr (fn);
- for (; d; d = d->block)
- optimize_code (d->next);
+ return 0;
+}
- break;
+/* Callback function for common function elimination, called from cfe_expr_0.
+ Put all eligible function expressions into expr_array. */
+
+static int
+cfe_register_funcs (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 with unknown charlens. */
+ if ((*e)->ts.type == BT_CHARACTER
+ && ((*e)->ts.u.cl == NULL || (*e)->ts.u.cl->length == NULL
+ || (*e)->ts.u.cl->length->expr_type != EXPR_CONSTANT))
+ return 0;
+
+ /* We don't do function elimination within FORALL statements, it can
+ lead to wrong-code in certain circumstances. */
+
+ if (forall_level > 0)
+ return 0;
+
+ /* Function elimination inside an iterator could lead to functions which
+ depend on iterator variables being moved outside. FIXME: We should check
+ if the functions do indeed depend on the iterator variable. */
+
+ if (iterator_level > 0)
+ return 0;
+
+ /* If we don't know the shape at compile time, we create an allocatable
+ temporary variable to hold the intermediate result, but only if
+ allocation on assignment is active. */
+
+ if ((*e)->rank > 0 && (*e)->shape == NULL && !gfc_option.flag_realloc_lhs)
+ return 0;
+
+ /* Skip the test for pure functions if -faggressive-function-elimination
+ is specified. */
+ if ((*e)->value.function.esym)
+ {
+ /* Don't create an array temporary for elemental functions. */
+ if ((*e)->value.function.esym->attr.elemental && (*e)->rank > 0)
+ return 0;
+
+ /* Only eliminate potentially impure functions if the
+ user specifically requested it. */
+ if (!gfc_option.flag_aggressive_function_elimination
+ && !(*e)->value.function.esym->attr.pure
+ && !(*e)->value.function.esym->attr.implicit_pure)
+ return 0;
+ }
+
+ if ((*e)->value.function.isym)
+ {
+ /* Conversions are handled on the fly by the middle end,
+ transpose during trans-* stages and TRANSFER by the middle end. */
+ if ((*e)->value.function.isym->id == GFC_ISYM_CONVERSION
+ || (*e)->value.function.isym->id == GFC_ISYM_TRANSFER
+ || gfc_inline_intrinsic_function_p (*e))
+ return 0;
+
+ /* Don't create an array temporary for elemental functions,
+ as this would be wasteful of memory.
+ FIXME: Create a scalar temporary during scalarization. */
+ if ((*e)->value.function.isym->elemental && (*e)->rank > 0)
+ return 0;
+
+ if (!(*e)->value.function.isym->pure)
+ return 0;
+ }
+
+ expr_array.safe_push (e);
+ return 0;
+}
+
+/* Auxiliary function to check if an expression is a temporary created by
+ create var. */
+
+static bool
+is_fe_temp (gfc_expr *e)
+{
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
+
+ return e->symtree->n.sym->attr.fe_temp;
+}
+
+
+/* Returns a new expression (a variable) to be used in place of the old one,
+ with an assignment statement before the current statement to set
+ the value of the variable. Creates a new BLOCK for the statement if
+ that hasn't already been done and puts the statement, plus the
+ newly created variables, in that block. Special cases: If the
+ expression is constant or a temporary which has already
+ been created, just copy it. */
+
+static 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;
+ gfc_namespace *ns;
+ int i;
+
+ if (e->expr_type == EXPR_CONSTANT || is_fe_temp (e))
+ return gfc_copy_expr (e);
+
+ /* If the block hasn't already been created, do so. */
+ if (inserted_block == NULL)
+ {
+ inserted_block = XCNEW (gfc_code);
+ inserted_block->op = EXEC_BLOCK;
+ inserted_block->loc = (*current_code)->loc;
+ ns = gfc_build_block_ns (current_ns);
+ inserted_block->ext.block.ns = ns;
+ inserted_block->ext.block.assoc = NULL;
+
+ ns->code = *current_code;
- case EXEC_WHERE:
- d = c->block;
- optimize_expr_0 (d->expr1);
- optimize_code (d->next);
+ /* If the statement has a label, make sure it is transferred to
+ the newly created block. */
- for (d = d->block; d; d = d->block)
+ if ((*current_code)->here)
{
- optimize_expr_0 (d->expr1);
- optimize_code (d->next);
+ inserted_block->here = (*current_code)->here;
+ (*current_code)->here = NULL;
}
- break;
- case EXEC_FORALL:
+ inserted_block->next = (*current_code)->next;
+ changed_statement = &(inserted_block->ext.block.ns->code);
+ (*current_code)->next = NULL;
+ /* Insert the BLOCK at the right position. */
+ *current_code = inserted_block;
+ ns->parent = current_ns;
+ }
+ else
+ ns = inserted_block->ext.block.ns;
+
+ sprintf(name, "__var_%d",num++);
+ if (gfc_get_sym_tree (name, ns, &symtree, false) != 0)
+ gcc_unreachable ();
+
+ symbol = symtree->n.sym;
+ symbol->ts = e->ts;
- for (fa = c->ext.forall_iterator; fa; fa = fa->next)
+ if (e->rank > 0)
+ {
+ symbol->as = gfc_get_array_spec ();
+ symbol->as->rank = e->rank;
+
+ if (e->shape == NULL)
{
- optimize_expr_0 (fa->start);
- optimize_expr_0 (fa->end);
- optimize_expr_0 (fa->stride);
+ /* We don't know the shape at compile time, so we use an
+ allocatable. */
+ symbol->as->type = AS_DEFERRED;
+ symbol->attr.allocatable = 1;
}
+ else
+ {
+ symbol->as->type = AS_EXPLICIT;
+ /* Copy the shape. */
+ 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;
+ }
+ }
+ }
- if (c->expr1 != NULL)
- optimize_expr_0 (c->expr1);
+ symbol->attr.flavor = FL_VARIABLE;
+ symbol->attr.referenced = 1;
+ symbol->attr.dimension = e->rank > 0;
+ symbol->attr.fe_temp = 1;
+ 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->ts.type == BT_CLASS
+ ? CLASS_DATA (symbol)->as : symbol->as;
+ if (warn_array_temporaries)
+ gfc_warning ("Creating array temporary at %L", &(e->where));
+ }
- optimize_code (c->block->next);
+ /* Generate the new assignment. */
+ n = XCNEW (gfc_code);
+ n->op = EXEC_ASSIGN;
+ n->loc = (*current_code)->loc;
+ n->next = *changed_statement;
+ n->expr1 = gfc_copy_expr (result);
+ n->expr2 = e;
+ *changed_statement = n;
- break;
+ return result;
+}
- case EXEC_CRITICAL:
- optimize_code (c->block->next);
- break;
+/* Warn about function elimination. */
- case EXEC_DO:
- optimize_expr_0 (c->ext.iterator->start);
- optimize_expr_0 (c->ext.iterator->end);
- optimize_expr_0 (c->ext.iterator->step);
- optimize_code (c->block->next);
+static void
+do_warn_function_elimination (gfc_expr *e)
+{
+ if (e->expr_type != EXPR_FUNCTION)
+ return;
+ if (e->value.function.esym)
+ gfc_warning ("Removing call to function '%s' at %L",
+ e->value.function.esym->name, &(e->where));
+ else if (e->value.function.isym)
+ gfc_warning ("Removing call to function '%s' at %L",
+ e->value.function.isym->name, &(e->where));
+}
+/* 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;
+ gfc_expr **ei, **ej;
- break;
+ /* Don't do this optimization within OMP workshare. */
- case EXEC_DO_WHILE:
- optimize_expr_0 (c->expr1);
- optimize_code (c->block->next);
- break;
+ if (in_omp_workshare)
+ {
+ *walk_subtrees = 0;
+ return 0;
+ }
+ expr_array.release ();
- case EXEC_ALLOCATE:
- for (a = c->ext.alloc.list; a; a = a->next)
- optimize_expr_0 (a->expr);
- break;
+ gfc_expr_walker (e, cfe_register_funcs, NULL);
+
+ /* Walk through all the functions. */
+
+ FOR_EACH_VEC_ELT_FROM (expr_array, i, ei, 1)
+ {
+ /* Skip if the function has been replaced by a variable already. */
+ if ((*ei)->expr_type == EXPR_VARIABLE)
+ continue;
+
+ newvar = NULL;
+ for (j=0; j<i; j++)
+ {
+ ej = expr_array[j];
+ if (gfc_dep_compare_functions (*ei, *ej, true) == 0)
+ {
+ if (newvar == NULL)
+ newvar = create_var (*ei);
+
+ if (warn_function_elimination)
+ do_warn_function_elimination (*ej);
+
+ free (*ej);
+ *ej = gfc_copy_expr (newvar);
+ }
+ }
+ if (newvar)
+ *ei = newvar;
+ }
+
+ /* We did all the necessary walking in this function. */
+ *walk_subtrees = 0;
+ return 0;
+}
+
+/* Callback function for common function elimination, called from
+ gfc_code_walker. This keeps track of the current code, in order
+ to insert statements as needed. */
+
+static int
+cfe_code (gfc_code **c, int *walk_subtrees, void *data ATTRIBUTE_UNUSED)
+{
+ current_code = c;
+ inserted_block = NULL;
+ changed_statement = NULL;
- /* Todo: Some of these may need to be optimized, as well. */
- case EXEC_WRITE:
- case EXEC_READ:
- case EXEC_OPEN:
- case EXEC_INQUIRE:
- case EXEC_REWIND:
- case EXEC_ENDFILE:
- case EXEC_BACKSPACE:
- case EXEC_CLOSE:
- case EXEC_WAIT:
- case EXEC_TRANSFER:
- case EXEC_FLUSH:
- case EXEC_IOLENGTH:
- case EXEC_END_PROCEDURE:
- case EXEC_NOP:
- case EXEC_CONTINUE:
- case EXEC_ENTRY:
- case EXEC_INIT_ASSIGN:
- case EXEC_LABEL_ASSIGN:
- case EXEC_POINTER_ASSIGN:
- case EXEC_GOTO:
- case EXEC_CYCLE:
- case EXEC_EXIT:
- case EXEC_BLOCK:
- case EXEC_END_BLOCK:
- case EXEC_OMP_ATOMIC:
- case EXEC_OMP_BARRIER:
- case EXEC_OMP_CRITICAL:
- case EXEC_OMP_FLUSH:
- case EXEC_OMP_DO:
- case EXEC_OMP_MASTER:
- case EXEC_OMP_ORDERED:
- case EXEC_OMP_PARALLEL:
- case EXEC_OMP_PARALLEL_DO:
- case EXEC_OMP_PARALLEL_SECTIONS:
- case EXEC_OMP_PARALLEL_WORKSHARE:
- case EXEC_OMP_SECTIONS:
- case EXEC_OMP_SINGLE:
- case EXEC_OMP_TASK:
- case EXEC_OMP_TASKWAIT:
- case EXEC_OMP_WORKSHARE:
- case EXEC_DEALLOCATE:
+ /* Do not do anything inside a WHERE statement; scalar assignments, BLOCKs
+ and allocation on assigment are prohibited inside WHERE, and finally
+ masking an expression would lead to wrong-code when replacing
+
+ WHERE (a>0)
+ b = sum(foo(a) + foo(a))
+ END WHERE
+
+ with
+
+ WHERE (a > 0)
+ tmp = foo(a)
+ b = sum(tmp + tmp)
+ END WHERE
+*/
+
+ if ((*c)->op == EXEC_WHERE)
+ {
+ *walk_subtrees = 0;
+ return 0;
+ }
+
+
+ return 0;
+}
+
+/* Dummy function for expression call back, for use when we
+ really don't want to do any walking. */
+
+static int
+dummy_expr_callback (gfc_expr **e ATTRIBUTE_UNUSED, int *walk_subtrees,
+ void *data ATTRIBUTE_UNUSED)
+{
+ *walk_subtrees = 0;
+ return 0;
+}
+
+/* Dummy function for code callback, for use when we really
+ don't want to do anything. */
+int
+gfc_dummy_code_callback (gfc_code **e ATTRIBUTE_UNUSED,
+ int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ return 0;
+}
+
+/* Code callback function for converting
+ do while(a)
+ end do
+ into the equivalent
+ do
+ if (.not. a) exit
+ end do
+ This is because common function elimination would otherwise place the
+ temporary variables outside the loop. */
+
+static int
+convert_do_while (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_code *co = *c;
+ gfc_code *c_if1, *c_if2, *c_exit;
+ gfc_code *loopblock;
+ gfc_expr *e_not, *e_cond;
+
+ if (co->op != EXEC_DO_WHILE)
+ return 0;
+
+ if (co->expr1 == NULL || co->expr1->expr_type == EXPR_CONSTANT)
+ return 0;
+
+ e_cond = co->expr1;
+
+ /* Generate the condition of the if statement, which is .not. the original
+ statement. */
+ e_not = gfc_get_expr ();
+ e_not->ts = e_cond->ts;
+ e_not->where = e_cond->where;
+ e_not->expr_type = EXPR_OP;
+ e_not->value.op.op = INTRINSIC_NOT;
+ e_not->value.op.op1 = e_cond;
+
+ /* Generate the EXIT statement. */
+ c_exit = XCNEW (gfc_code);
+ c_exit->op = EXEC_EXIT;
+ c_exit->ext.which_construct = co;
+ c_exit->loc = co->loc;
+
+ /* Generate the IF statement. */
+ c_if2 = XCNEW (gfc_code);
+ c_if2->op = EXEC_IF;
+ c_if2->expr1 = e_not;
+ c_if2->next = c_exit;
+ c_if2->loc = co->loc;
+
+ /* ... plus the one to chain it to. */
+ c_if1 = XCNEW (gfc_code);
+ c_if1->op = EXEC_IF;
+ c_if1->block = c_if2;
+ c_if1->loc = co->loc;
+
+ /* Make the DO WHILE loop into a DO block by replacing the condition
+ with a true constant. */
+ co->expr1 = gfc_get_logical_expr (gfc_default_integer_kind, &co->loc, true);
+
+ /* Hang the generated if statement into the loop body. */
+
+ loopblock = co->block->next;
+ co->block->next = c_if1;
+ c_if1->next = loopblock;
+
+ return 0;
+}
+
+/* Code callback function for converting
+ if (a) then
+ ...
+ else if (b) then
+ end if
+
+ into
+ if (a) then
+ else
+ if (b) then
+ end if
+ end if
+
+ because otherwise common function elimination would place the BLOCKs
+ into the wrong place. */
+
+static int
+convert_elseif (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_code *co = *c;
+ gfc_code *c_if1, *c_if2, *else_stmt;
+
+ if (co->op != EXEC_IF)
+ return 0;
+
+ /* This loop starts out with the first ELSE statement. */
+ else_stmt = co->block->block;
+
+ while (else_stmt != NULL)
+ {
+ gfc_code *next_else;
+
+ /* If there is no condition, we're done. */
+ if (else_stmt->expr1 == NULL)
+ break;
+
+ next_else = else_stmt->block;
+
+ /* Generate the new IF statement. */
+ c_if2 = XCNEW (gfc_code);
+ c_if2->op = EXEC_IF;
+ c_if2->expr1 = else_stmt->expr1;
+ c_if2->next = else_stmt->next;
+ c_if2->loc = else_stmt->loc;
+ c_if2->block = next_else;
+
+ /* ... plus the one to chain it to. */
+ c_if1 = XCNEW (gfc_code);
+ c_if1->op = EXEC_IF;
+ c_if1->block = c_if2;
+ c_if1->loc = else_stmt->loc;
+
+ /* Insert the new IF after the ELSE. */
+ else_stmt->expr1 = NULL;
+ else_stmt->next = c_if1;
+ else_stmt->block = NULL;
+
+ else_stmt = next_else;
+ }
+ /* Don't walk subtrees. */
+ return 0;
+}
+/* Optimize a namespace, including all contained namespaces. */
+
+static void
+optimize_namespace (gfc_namespace *ns)
+{
+
+ current_ns = ns;
+ forall_level = 0;
+ iterator_level = 0;
+ in_assoc_list = false;
+ in_omp_workshare = false;
+
+ gfc_code_walker (&ns->code, convert_do_while, dummy_expr_callback, NULL);
+ gfc_code_walker (&ns->code, convert_elseif, dummy_expr_callback, NULL);
+ gfc_code_walker (&ns->code, cfe_code, cfe_expr_0, NULL);
+ gfc_code_walker (&ns->code, optimize_code, optimize_expr, NULL);
+
+ /* BLOCKs are handled in the expression walker below. */
+ for (ns = ns->contained; ns; ns = ns->sibling)
+ {
+ if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
+ optimize_namespace (ns);
+ }
+}
+
+static void
+optimize_reduction (gfc_namespace *ns)
+{
+ current_ns = ns;
+ gfc_code_walker (&ns->code, gfc_dummy_code_callback,
+ callback_reduction, NULL);
+
+/* BLOCKs are handled in the expression walker below. */
+ for (ns = ns->contained; ns; ns = ns->sibling)
+ {
+ if (ns->code == NULL || ns->code->op != EXEC_BLOCK)
+ optimize_reduction (ns);
+ }
+}
+
+/* Replace code like
+ a = matmul(b,c) + d
+ with
+ a = matmul(b,c) ; a = a + d
+ where the array function is not elemental and not allocatable
+ and does not depend on the left-hand side.
+*/
+
+static bool
+optimize_binop_array_assignment (gfc_code *c, gfc_expr **rhs, bool seen_op)
+{
+ gfc_expr *e;
+
+ e = *rhs;
+ if (e->expr_type == EXPR_OP)
+ {
+ switch (e->value.op.op)
+ {
+ /* Unary operators and exponentiation: Only look at a single
+ operand. */
+ case INTRINSIC_NOT:
+ case INTRINSIC_UPLUS:
+ case INTRINSIC_UMINUS:
+ case INTRINSIC_PARENTHESES:
+ case INTRINSIC_POWER:
+ if (optimize_binop_array_assignment (c, &e->value.op.op1, seen_op))
+ return true;
+ break;
+
+ case INTRINSIC_CONCAT:
+ /* Do not do string concatenations. */
+ break;
+
+ default:
+ /* Binary operators. */
+ if (optimize_binop_array_assignment (c, &e->value.op.op1, true))
+ return true;
+
+ if (optimize_binop_array_assignment (c, &e->value.op.op2, true))
+ return true;
+
+ break;
+ }
+ }
+ else if (seen_op && e->expr_type == EXPR_FUNCTION && e->rank > 0
+ && ! (e->value.function.esym
+ && (e->value.function.esym->attr.elemental
+ || e->value.function.esym->attr.allocatable
+ || e->value.function.esym->ts.type != c->expr1->ts.type
+ || e->value.function.esym->ts.kind != c->expr1->ts.kind))
+ && ! (e->value.function.isym
+ && (e->value.function.isym->elemental
+ || e->ts.type != c->expr1->ts.type
+ || e->ts.kind != c->expr1->ts.kind))
+ && ! gfc_inline_intrinsic_function_p (e))
+ {
+
+ gfc_code *n;
+ gfc_expr *new_expr;
+
+ /* Insert a new assignment statement after the current one. */
+ n = XCNEW (gfc_code);
+ n->op = EXEC_ASSIGN;
+ n->loc = c->loc;
+ n->next = c->next;
+ c->next = n;
+
+ n->expr1 = gfc_copy_expr (c->expr1);
+ n->expr2 = c->expr2;
+ new_expr = gfc_copy_expr (c->expr1);
+ c->expr2 = e;
+ *rhs = new_expr;
- break;
+ return true;
- default:
- gcc_unreachable ();
+ }
+
+ /* Nothing to optimize. */
+ return false;
+}
+
+/* Remove unneeded TRIMs at the end of expressions. */
+
+static bool
+remove_trim (gfc_expr *rhs)
+{
+ bool ret;
+
+ ret = false;
+ /* Check for a // b // trim(c). Looping is probably not
+ necessary because the parser usually generates
+ (// (// a b ) trim(c) ) , but better safe than sorry. */
+
+ while (rhs->expr_type == EXPR_OP
+ && rhs->value.op.op == INTRINSIC_CONCAT)
+ rhs = rhs->value.op.op2;
+
+ while (rhs->expr_type == EXPR_FUNCTION && rhs->value.function.isym
+ && rhs->value.function.isym->id == GFC_ISYM_TRIM)
+ {
+ strip_function_call (rhs);
+ /* Recursive call to catch silly stuff like trim ( a // trim(b)). */
+ remove_trim (rhs);
+ ret = true;
}
+
+ return ret;
}
/* Optimizations for an assignment. */
lhs = c->expr1;
rhs = c->expr2;
- /* Optimize away a = trim(b), where a is a character variable. */
-
- if (lhs->ts.type == BT_CHARACTER)
+ if (lhs->ts.type == BT_CHARACTER && !lhs->ts.deferred)
{
- if (rhs->expr_type == EXPR_FUNCTION &&
- rhs->value.function.isym &&
- rhs->value.function.isym->id == GFC_ISYM_TRIM)
- {
- strip_function_call (rhs);
- optimize_assignment (c);
- return;
- }
- }
+ /* Optimize a = trim(b) to a = b. */
+ remove_trim (rhs);
- /* All direct optimizations have been done. Now it's time
- to optimize the rhs. */
+ /* Replace a = ' ' by a = '' to optimize away a memcpy. */
+ if (is_empty_string (rhs))
+ rhs->value.character.length = 0;
+ }
- optimize_expr_0 (rhs);
+ if (lhs->rank > 0 && gfc_check_dependency (lhs, rhs, true) == 0)
+ optimize_binop_array_assignment (c, &rhs, false);
}
/* Graft the argument expression onto the original function. */
*e = *e1;
- gfc_free (e1);
+ free (e1);
}
-/* Top-level optimization of expressions. Calls gfc_simplify_expr if
- optimize_expr succeeds in doing something.
- TODO: Optimization of multiple function occurrence to come here. */
+/* Optimization of lexical comparison functions. */
-static void
-optimize_expr_0 (gfc_expr * e)
+static bool
+optimize_lexical_comparison (gfc_expr *e)
{
- if (optimize_expr (e))
- gfc_simplify_expr (e, 0);
+ if (e->expr_type != EXPR_FUNCTION || e->value.function.isym == NULL)
+ return false;
+
+ switch (e->value.function.isym->id)
+ {
+ case GFC_ISYM_LLE:
+ return optimize_comparison (e, INTRINSIC_LE);
+
+ case GFC_ISYM_LGE:
+ return optimize_comparison (e, INTRINSIC_GE);
+
+ case GFC_ISYM_LGT:
+ return optimize_comparison (e, INTRINSIC_GT);
+
+ case GFC_ISYM_LLT:
+ return optimize_comparison (e, INTRINSIC_LT);
- return;
+ default:
+ break;
+ }
+ return false;
}
-/* Recursive optimization of expressions.
- TODO: Make this handle many more things. */
+/* Combine stuff like [a]>b into [a>b], for easier optimization later. Do not
+ do CHARACTER because of possible pessimization involving character
+ lengths. */
static bool
-optimize_expr (gfc_expr *e)
+combine_array_constructor (gfc_expr *e)
{
- bool ret;
- if (e == NULL)
+ gfc_expr *op1, *op2;
+ gfc_expr *scalar;
+ gfc_expr *new_expr;
+ gfc_constructor *c, *new_c;
+ gfc_constructor_base oldbase, newbase;
+ bool scalar_first;
+
+ /* Array constructors have rank one. */
+ if (e->rank != 1)
return false;
- ret = false;
+ /* Don't try to combine association lists, this makes no sense
+ and leads to an ICE. */
+ if (in_assoc_list)
+ return false;
+
+ op1 = e->value.op.op1;
+ op2 = e->value.op.op2;
- switch (e->expr_type)
+ if (op1->expr_type == EXPR_ARRAY && op2->rank == 0)
+ scalar_first = false;
+ else if (op2->expr_type == EXPR_ARRAY && op1->rank == 0)
{
- case EXPR_OP:
- return optimize_op (e);
- break;
+ scalar_first = true;
+ op1 = e->value.op.op2;
+ op2 = e->value.op.op1;
+ }
+ else
+ return false;
- case EXPR_FUNCTION:
- optimize_actual_arglist (e->value.function.actual);
- break;
+ if (op2->ts.type == BT_CHARACTER)
+ return false;
- default:
- break;
+ scalar = create_var (gfc_copy_expr (op2));
+
+ oldbase = op1->value.constructor;
+ newbase = NULL;
+ e->expr_type = EXPR_ARRAY;
+
+ for (c = gfc_constructor_first (oldbase); c;
+ c = gfc_constructor_next (c))
+ {
+ new_expr = gfc_get_expr ();
+ new_expr->ts = e->ts;
+ new_expr->expr_type = EXPR_OP;
+ new_expr->rank = c->expr->rank;
+ new_expr->where = c->where;
+ new_expr->value.op.op = e->value.op.op;
+
+ if (scalar_first)
+ {
+ new_expr->value.op.op1 = gfc_copy_expr (scalar);
+ new_expr->value.op.op2 = gfc_copy_expr (c->expr);
+ }
+ else
+ {
+ new_expr->value.op.op1 = gfc_copy_expr (c->expr);
+ new_expr->value.op.op2 = gfc_copy_expr (scalar);
+ }
+
+ new_c = gfc_constructor_append_expr (&newbase, new_expr, &(e->where));
+ new_c->iterator = c->iterator;
+ c->iterator = NULL;
}
- return ret;
+ gfc_free_expr (op1);
+ gfc_free_expr (op2);
+ gfc_free_expr (scalar);
+
+ e->value.constructor = newbase;
+ return true;
+}
+
+/* Change (-1)**k into 1-ishift(iand(k,1),1) and
+ 2**k into ishift(1,k) */
+
+static bool
+optimize_power (gfc_expr *e)
+{
+ gfc_expr *op1, *op2;
+ gfc_expr *iand, *ishft;
+
+ if (e->ts.type != BT_INTEGER)
+ return false;
+
+ op1 = e->value.op.op1;
+
+ if (op1 == NULL || op1->expr_type != EXPR_CONSTANT)
+ return false;
+
+ if (mpz_cmp_si (op1->value.integer, -1L) == 0)
+ {
+ gfc_free_expr (op1);
+
+ op2 = e->value.op.op2;
+
+ if (op2 == NULL)
+ return false;
+
+ iand = gfc_build_intrinsic_call (current_ns, GFC_ISYM_IAND,
+ "_internal_iand", e->where, 2, op2,
+ gfc_get_int_expr (e->ts.kind,
+ &e->where, 1));
+
+ ishft = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ISHFT,
+ "_internal_ishft", e->where, 2, iand,
+ gfc_get_int_expr (e->ts.kind,
+ &e->where, 1));
+
+ e->value.op.op = INTRINSIC_MINUS;
+ e->value.op.op1 = gfc_get_int_expr (e->ts.kind, &e->where, 1);
+ e->value.op.op2 = ishft;
+ return true;
+ }
+ else if (mpz_cmp_si (op1->value.integer, 2L) == 0)
+ {
+ gfc_free_expr (op1);
+
+ op2 = e->value.op.op2;
+ if (op2 == NULL)
+ return false;
+
+ ishft = gfc_build_intrinsic_call (current_ns, GFC_ISYM_ISHFT,
+ "_internal_ishft", e->where, 2,
+ gfc_get_int_expr (e->ts.kind,
+ &e->where, 1),
+ op2);
+ *e = *ishft;
+ return true;
+ }
+
+ else if (mpz_cmp_si (op1->value.integer, 1L) == 0)
+ {
+ op2 = e->value.op.op2;
+ if (op2 == NULL)
+ return false;
+
+ gfc_free_expr (op1);
+ gfc_free_expr (op2);
+
+ e->expr_type = EXPR_CONSTANT;
+ e->value.op.op1 = NULL;
+ e->value.op.op2 = NULL;
+ mpz_init_set_si (e->value.integer, 1);
+ /* Typespec and location are still OK. */
+ return true;
+ }
+
+ return false;
}
/* Recursive optimization of operators. */
static bool
optimize_op (gfc_expr *e)
{
+ bool changed;
- gfc_intrinsic_op op;
+ gfc_intrinsic_op op = e->value.op.op;
- op = e->value.op.op;
+ changed = false;
- switch (op)
+ /* Only use new-style comparisons. */
+ switch(op)
{
- case INTRINSIC_EQ:
case INTRINSIC_EQ_OS:
- case INTRINSIC_GE:
+ op = INTRINSIC_EQ;
+ break;
+
case INTRINSIC_GE_OS:
- case INTRINSIC_LE:
+ op = INTRINSIC_GE;
+ break;
+
case INTRINSIC_LE_OS:
- return optimize_equality (e, true);
+ op = INTRINSIC_LE;
break;
- case INTRINSIC_NE:
case INTRINSIC_NE_OS:
- case INTRINSIC_GT:
+ op = INTRINSIC_NE;
+ break;
+
case INTRINSIC_GT_OS:
- case INTRINSIC_LT:
+ op = INTRINSIC_GT;
+ break;
+
case INTRINSIC_LT_OS:
- return optimize_equality (e, false);
+ op = INTRINSIC_LT;
+ break;
+
+ default:
+ break;
+ }
+
+ switch (op)
+ {
+ case INTRINSIC_EQ:
+ case INTRINSIC_GE:
+ case INTRINSIC_LE:
+ case INTRINSIC_NE:
+ case INTRINSIC_GT:
+ case INTRINSIC_LT:
+ changed = optimize_comparison (e, op);
+
+ /* Fall through */
+ /* Look at array constructors. */
+ case INTRINSIC_PLUS:
+ case INTRINSIC_MINUS:
+ case INTRINSIC_TIMES:
+ case INTRINSIC_DIVIDE:
+ return combine_array_constructor (e) || changed;
+
+ case INTRINSIC_POWER:
+ return optimize_power (e);
break;
default:
return false;
}
-/* Optimize expressions for equality. */
+
+/* Return true if a constant string contains only blanks. */
static bool
-optimize_equality (gfc_expr *e, bool equal)
+is_empty_string (gfc_expr *e)
+{
+ int i;
+
+ if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
+ return false;
+
+ for (i=0; i < e->value.character.length; i++)
+ {
+ if (e->value.character.string[i] != ' ')
+ return false;
+ }
+
+ return true;
+}
+
+
+/* Insert a call to the intrinsic len_trim. Use a different name for
+ the symbol tree so we don't run into trouble when the user has
+ renamed len_trim for some reason. */
+
+static gfc_expr*
+get_len_trim_call (gfc_expr *str, int kind)
{
+ gfc_expr *fcn;
+ gfc_actual_arglist *actual_arglist, *next;
+
+ 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 = str;
+ next = gfc_get_actual_arglist ();
+ next->expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, kind);
+ actual_arglist->next = next;
+
+ fcn->value.function.actual = actual_arglist;
+ fcn->where = str->where;
+ fcn->ts.type = BT_INTEGER;
+ fcn->ts.kind = gfc_charlen_int_kind;
+
+ gfc_get_sym_tree ("__internal_len_trim", current_ns, &fcn->symtree, false);
+ fcn->symtree->n.sym->ts = fcn->ts;
+ fcn->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+ fcn->symtree->n.sym->attr.function = 1;
+ fcn->symtree->n.sym->attr.elemental = 1;
+ fcn->symtree->n.sym->attr.referenced = 1;
+ fcn->symtree->n.sym->attr.access = ACCESS_PRIVATE;
+ gfc_commit_symbol (fcn->symtree->n.sym);
+
+ return fcn;
+}
+/* Optimize expressions for equality. */
+
+static bool
+optimize_comparison (gfc_expr *e, gfc_intrinsic_op op)
+{
gfc_expr *op1, *op2;
bool change;
+ int eq;
+ bool result;
+ gfc_actual_arglist *firstarg, *secondarg;
- op1 = e->value.op.op1;
- op2 = e->value.op.op2;
+ if (e->expr_type == EXPR_OP)
+ {
+ firstarg = NULL;
+ secondarg = NULL;
+ op1 = e->value.op.op1;
+ op2 = e->value.op.op2;
+ }
+ else if (e->expr_type == EXPR_FUNCTION)
+ {
+ /* One of the lexical comparison functions. */
+ firstarg = e->value.function.actual;
+ secondarg = firstarg->next;
+ op1 = firstarg->expr;
+ op2 = secondarg->expr;
+ }
+ else
+ gcc_unreachable ();
/* Strip off unneeded TRIM calls from string comparisons. */
- change = false;
+ change = remove_trim (op1);
+
+ if (remove_trim (op2))
+ change = true;
- if (op1->expr_type == EXPR_FUNCTION
- && op1->value.function.isym
- && op1->value.function.isym->id == GFC_ISYM_TRIM)
+ /* An expression of type EXPR_CONSTANT is only valid for scalars. */
+ /* TODO: A scalar constant may be acceptable in some cases (the scalarizer
+ handles them well). However, there are also cases that need a non-scalar
+ argument. For example the any intrinsic. See PR 45380. */
+ if (e->rank > 0)
+ return change;
+
+ /* Replace a == '' with len_trim(a) == 0 and a /= '' with
+ len_trim(a) != 0 */
+ if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
+ && (op == INTRINSIC_EQ || op == INTRINSIC_NE))
{
- strip_function_call (op1);
- change = true;
+ bool empty_op1, empty_op2;
+ empty_op1 = is_empty_string (op1);
+ empty_op2 = is_empty_string (op2);
+
+ if (empty_op1 || empty_op2)
+ {
+ gfc_expr *fcn;
+ gfc_expr *zero;
+ gfc_expr *str;
+
+ /* This can only happen when an error for comparing
+ characters of different kinds has already been issued. */
+ if (empty_op1 && empty_op2)
+ return false;
+
+ zero = gfc_get_int_expr (gfc_charlen_int_kind, &e->where, 0);
+ str = empty_op1 ? op2 : op1;
+
+ fcn = get_len_trim_call (str, gfc_charlen_int_kind);
+
+
+ if (empty_op1)
+ gfc_free_expr (op1);
+ else
+ gfc_free_expr (op2);
+
+ op1 = fcn;
+ op2 = zero;
+ e->value.op.op1 = fcn;
+ e->value.op.op2 = zero;
+ }
}
- if (op2->expr_type == EXPR_FUNCTION
- && op2->value.function.isym
- && op2->value.function.isym->id == GFC_ISYM_TRIM)
+
+ /* Don't compare REAL or COMPLEX expressions when honoring NaNs. */
+
+ if (flag_finite_math_only
+ || (op1->ts.type != BT_REAL && op2->ts.type != BT_REAL
+ && op1->ts.type != BT_COMPLEX && op2->ts.type != BT_COMPLEX))
{
- strip_function_call (op2);
- change = true;
+ eq = gfc_dep_compare_expr (op1, op2);
+ if (eq <= -2)
+ {
+ /* Replace A // B < A // C with B < C, and A // B < C // B
+ with A < C. */
+ if (op1->ts.type == BT_CHARACTER && op2->ts.type == BT_CHARACTER
+ && op1->expr_type == EXPR_OP
+ && op1->value.op.op == INTRINSIC_CONCAT
+ && op2->expr_type == EXPR_OP
+ && op2->value.op.op == INTRINSIC_CONCAT)
+ {
+ gfc_expr *op1_left = op1->value.op.op1;
+ gfc_expr *op2_left = op2->value.op.op1;
+ gfc_expr *op1_right = op1->value.op.op2;
+ gfc_expr *op2_right = op2->value.op.op2;
+
+ if (gfc_dep_compare_expr (op1_left, op2_left) == 0)
+ {
+ /* Watch out for 'A ' // x vs. 'A' // x. */
+
+ if (op1_left->expr_type == EXPR_CONSTANT
+ && op2_left->expr_type == EXPR_CONSTANT
+ && op1_left->value.character.length
+ != op2_left->value.character.length)
+ return change;
+ else
+ {
+ free (op1_left);
+ free (op2_left);
+ if (firstarg)
+ {
+ firstarg->expr = op1_right;
+ secondarg->expr = op2_right;
+ }
+ else
+ {
+ e->value.op.op1 = op1_right;
+ e->value.op.op2 = op2_right;
+ }
+ optimize_comparison (e, op);
+ return true;
+ }
+ }
+ if (gfc_dep_compare_expr (op1_right, op2_right) == 0)
+ {
+ free (op1_right);
+ free (op2_right);
+ if (firstarg)
+ {
+ firstarg->expr = op1_left;
+ secondarg->expr = op2_left;
+ }
+ else
+ {
+ e->value.op.op1 = op1_left;
+ e->value.op.op2 = op2_left;
+ }
+
+ optimize_comparison (e, op);
+ return true;
+ }
+ }
+ }
+ else
+ {
+ /* eq can only be -1, 0 or 1 at this point. */
+ switch (op)
+ {
+ case INTRINSIC_EQ:
+ result = eq == 0;
+ break;
+
+ case INTRINSIC_GE:
+ result = eq >= 0;
+ break;
+
+ case INTRINSIC_LE:
+ result = eq <= 0;
+ break;
+
+ case INTRINSIC_NE:
+ result = eq != 0;
+ break;
+
+ case INTRINSIC_GT:
+ result = eq > 0;
+ break;
+
+ case INTRINSIC_LT:
+ result = eq < 0;
+ break;
+
+ default:
+ gfc_internal_error ("illegal OP in optimize_comparison");
+ break;
+ }
+
+ /* Replace the expression by a constant expression. The typespec
+ and where remains the way it is. */
+ free (op1);
+ free (op2);
+ e->expr_type = EXPR_CONSTANT;
+ e->value.logical = result;
+ return true;
+ }
}
- if (change)
+ return change;
+}
+
+/* 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. */
+
+static bool
+optimize_trim (gfc_expr *e)
+{
+ gfc_expr *a;
+ gfc_ref *ref;
+ gfc_expr *fcn;
+ gfc_ref **rr = NULL;
+
+ /* Don't do this optimization within an argument list, because
+ otherwise aliasing issues may occur. */
+
+ if (count_arglist != 1)
+ return false;
+
+ if (e->ts.type != BT_CHARACTER || e->expr_type != EXPR_FUNCTION
+ || e->value.function.isym == NULL
+ || e->value.function.isym->id != GFC_ISYM_TRIM)
+ return false;
+
+ a = e->value.function.actual->expr;
+
+ if (a->expr_type != EXPR_VARIABLE)
+ return false;
+
+ /* Follow all references to find the correct place to put the newly
+ created reference. FIXME: Also handle substring references and
+ array references. Array references cause strange regressions at
+ the moment. */
+
+ if (a->ref)
{
- optimize_equality (e, equal);
- return true;
+ for (rr = &(a->ref); *rr; rr = &((*rr)->next))
+ {
+ if ((*rr)->type == REF_SUBSTRING || (*rr)->type == REF_ARRAY)
+ return false;
+ }
}
- /* Check for direct comparison between identical variables.
- TODO: Handle cases with identical refs. */
- if (op1->expr_type == EXPR_VARIABLE
- && op2->expr_type == EXPR_VARIABLE
- && op1->symtree == op2->symtree
- && op1->ref == NULL && op2->ref == NULL
- && op1->ts.type != BT_REAL && op2->ts.type != BT_REAL
- && op1->ts.type != BT_COMPLEX && op2->ts.type !=BT_COMPLEX)
+ strip_function_call (e);
+
+ if (e->ref == NULL)
+ rr = &(e->ref);
+
+ /* Create the reference. */
+
+ ref = gfc_get_ref ();
+ ref->type = REF_SUBSTRING;
+
+ /* Set the start of the reference. */
+
+ ref->u.ss.start = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+
+ /* Build the function call to len_trim(x, gfc_default_integer_kind). */
+
+ fcn = get_len_trim_call (gfc_copy_expr (e), gfc_default_integer_kind);
+
+ /* Set the end of the reference to the call to len_trim. */
+
+ ref->u.ss.end = fcn;
+ gcc_assert (rr != NULL && *rr == NULL);
+ *rr = ref;
+ return true;
+}
+
+/* Optimize minloc(b), where b is rank 1 array, into
+ (/ minloc(b, dim=1) /), and similarly for maxloc,
+ as the latter forms are expanded inline. */
+
+static void
+optimize_minmaxloc (gfc_expr **e)
+{
+ gfc_expr *fn = *e;
+ gfc_actual_arglist *a;
+ char *name, *p;
+
+ if (fn->rank != 1
+ || fn->value.function.actual == NULL
+ || fn->value.function.actual->expr == NULL
+ || fn->value.function.actual->expr->rank != 1)
+ return;
+
+ *e = gfc_get_array_expr (fn->ts.type, fn->ts.kind, &fn->where);
+ (*e)->shape = fn->shape;
+ fn->rank = 0;
+ fn->shape = NULL;
+ gfc_constructor_append_expr (&(*e)->value.constructor, fn, &fn->where);
+
+ name = XALLOCAVEC (char, strlen (fn->value.function.name) + 1);
+ strcpy (name, fn->value.function.name);
+ p = strstr (name, "loc0");
+ p[3] = '1';
+ fn->value.function.name = gfc_get_string (name);
+ if (fn->value.function.actual->next)
{
- /* Replace the expression by a constant expression. The typespec
- and where remains the way it is. */
- gfc_free (op1);
- gfc_free (op2);
- e->expr_type = EXPR_CONSTANT;
- e->value.logical = equal;
- return true;
+ a = fn->value.function.actual->next;
+ gcc_assert (a->expr == NULL);
}
- return false;
+ else
+ {
+ a = gfc_get_actual_arglist ();
+ fn->value.function.actual->next = a;
+ }
+ a->expr = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
+ &fn->where);
+ mpz_set_ui (a->expr->value.integer, 1);
}
-/* Optimize a call list. Right now, this just goes through the actual
- arg list and optimizes each expression in turn. */
+/* Callback function for code checking that we do not pass a DO variable to an
+ INTENT(OUT) or INTENT(INOUT) dummy variable. */
+
+static int
+doloop_code (gfc_code **c, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_code *co;
+ int i;
+ gfc_formal_arglist *f;
+ gfc_actual_arglist *a;
+ gfc_code *cl;
+
+ co = *c;
+
+ /* If the doloop_list grew, we have to truncate it here. */
+
+ if ((unsigned) doloop_level < doloop_list.length())
+ doloop_list.truncate (doloop_level);
+
+ switch (co->op)
+ {
+ case EXEC_DO:
+
+ if (co->ext.iterator && co->ext.iterator->var)
+ doloop_list.safe_push (co);
+ else
+ doloop_list.safe_push ((gfc_code *) NULL);
+ break;
+
+ case EXEC_CALL:
+
+ if (co->resolved_sym == NULL)
+ break;
+
+ f = gfc_sym_get_dummy_args (co->resolved_sym);
+
+ /* Withot a formal arglist, there is only unknown INTENT,
+ which we don't check for. */
+ if (f == NULL)
+ break;
+
+ a = co->ext.actual;
+
+ while (a && f)
+ {
+ FOR_EACH_VEC_ELT (doloop_list, i, cl)
+ {
+ gfc_symbol *do_sym;
+
+ if (cl == NULL)
+ break;
+
+ do_sym = cl->ext.iterator->var->symtree->n.sym;
+
+ if (a->expr && a->expr->symtree
+ && a->expr->symtree->n.sym == do_sym)
+ {
+ if (f->sym->attr.intent == INTENT_OUT)
+ gfc_error_now_1 ("Variable '%s' at %L set to undefined "
+ "value inside loop beginning at %L as "
+ "INTENT(OUT) argument to subroutine '%s'",
+ do_sym->name, &a->expr->where,
+ &doloop_list[i]->loc,
+ co->symtree->n.sym->name);
+ else if (f->sym->attr.intent == INTENT_INOUT)
+ gfc_error_now_1 ("Variable '%s' at %L not definable inside "
+ "loop beginning at %L as INTENT(INOUT) "
+ "argument to subroutine '%s'",
+ do_sym->name, &a->expr->where,
+ &doloop_list[i]->loc,
+ co->symtree->n.sym->name);
+ }
+ }
+ a = a->next;
+ f = f->next;
+ }
+ break;
+
+ default:
+ break;
+ }
+ return 0;
+}
+
+/* Callback function for functions checking that we do not pass a DO variable
+ to an INTENT(OUT) or INTENT(INOUT) dummy variable. */
+
+static int
+do_function (gfc_expr **e, int *walk_subtrees ATTRIBUTE_UNUSED,
+ void *data ATTRIBUTE_UNUSED)
+{
+ gfc_formal_arglist *f;
+ gfc_actual_arglist *a;
+ gfc_expr *expr;
+ gfc_code *dl;
+ int i;
+
+ expr = *e;
+ if (expr->expr_type != EXPR_FUNCTION)
+ return 0;
+
+ /* Intrinsic functions don't modify their arguments. */
+
+ if (expr->value.function.isym)
+ return 0;
+
+ f = gfc_sym_get_dummy_args (expr->symtree->n.sym);
+
+ /* Without a formal arglist, there is only unknown INTENT,
+ which we don't check for. */
+ if (f == NULL)
+ return 0;
+
+ a = expr->value.function.actual;
+
+ while (a && f)
+ {
+ FOR_EACH_VEC_ELT (doloop_list, i, dl)
+ {
+ gfc_symbol *do_sym;
+
+ if (dl == NULL)
+ break;
+
+ do_sym = dl->ext.iterator->var->symtree->n.sym;
+
+ if (a->expr && a->expr->symtree
+ && a->expr->symtree->n.sym == do_sym)
+ {
+ if (f->sym->attr.intent == INTENT_OUT)
+ gfc_error_now_1 ("Variable '%s' at %L set to undefined value "
+ "inside loop beginning at %L as INTENT(OUT) "
+ "argument to function '%s'", do_sym->name,
+ &a->expr->where, &doloop_list[i]->loc,
+ expr->symtree->n.sym->name);
+ else if (f->sym->attr.intent == INTENT_INOUT)
+ gfc_error_now_1 ("Variable '%s' at %L not definable inside loop"
+ " beginning at %L as INTENT(INOUT) argument to"
+ " function '%s'", do_sym->name,
+ &a->expr->where, &doloop_list[i]->loc,
+ expr->symtree->n.sym->name);
+ }
+ }
+ a = a->next;
+ f = f->next;
+ }
+
+ return 0;
+}
static void
-optimize_actual_arglist (gfc_actual_arglist *a)
+doloop_warn (gfc_namespace *ns)
{
+ gfc_code_walker (&ns->code, doloop_code, do_function, NULL);
+}
+
+
+#define WALK_SUBEXPR(NODE) \
+ do \
+ { \
+ result = gfc_expr_walker (&(NODE), exprfn, data); \
+ if (result) \
+ return result; \
+ } \
+ while (0)
+#define WALK_SUBEXPR_TAIL(NODE) e = &(NODE); continue
+
+/* Walk expression *E, calling EXPRFN on each expression in it. */
- for (; a; a = a->next)
+int
+gfc_expr_walker (gfc_expr **e, walk_expr_fn_t exprfn, void *data)
+{
+ while (*e)
{
- if (a->expr != NULL)
- optimize_expr_0 (a->expr);
+ int walk_subtrees = 1;
+ gfc_actual_arglist *a;
+ gfc_ref *r;
+ gfc_constructor *c;
+
+ int result = exprfn (e, &walk_subtrees, data);
+ if (result)
+ return result;
+ if (walk_subtrees)
+ switch ((*e)->expr_type)
+ {
+ case EXPR_OP:
+ WALK_SUBEXPR ((*e)->value.op.op1);
+ WALK_SUBEXPR_TAIL ((*e)->value.op.op2);
+ break;
+ case EXPR_FUNCTION:
+ for (a = (*e)->value.function.actual; a; a = a->next)
+ WALK_SUBEXPR (a->expr);
+ break;
+ case EXPR_COMPCALL:
+ case EXPR_PPC:
+ WALK_SUBEXPR ((*e)->value.compcall.base_object);
+ for (a = (*e)->value.compcall.actual; a; a = a->next)
+ WALK_SUBEXPR (a->expr);
+ break;
+
+ case EXPR_STRUCTURE:
+ case EXPR_ARRAY:
+ for (c = gfc_constructor_first ((*e)->value.constructor); c;
+ c = gfc_constructor_next (c))
+ {
+ if (c->iterator == NULL)
+ WALK_SUBEXPR (c->expr);
+ else
+ {
+ iterator_level ++;
+ WALK_SUBEXPR (c->expr);
+ iterator_level --;
+ WALK_SUBEXPR (c->iterator->var);
+ WALK_SUBEXPR (c->iterator->start);
+ WALK_SUBEXPR (c->iterator->end);
+ WALK_SUBEXPR (c->iterator->step);
+ }
+ }
+
+ if ((*e)->expr_type != EXPR_ARRAY)
+ break;
+
+ /* Fall through to the variable case in order to walk the
+ reference. */
+
+ case EXPR_SUBSTRING:
+ case EXPR_VARIABLE:
+ for (r = (*e)->ref; r; r = r->next)
+ {
+ gfc_array_ref *ar;
+ int i;
+
+ switch (r->type)
+ {
+ case REF_ARRAY:
+ ar = &r->u.ar;
+ if (ar->type == AR_SECTION || ar->type == AR_ELEMENT)
+ {
+ for (i=0; i< ar->dimen; i++)
+ {
+ WALK_SUBEXPR (ar->start[i]);
+ WALK_SUBEXPR (ar->end[i]);
+ WALK_SUBEXPR (ar->stride[i]);
+ }
+ }
+
+ break;
+
+ case REF_SUBSTRING:
+ WALK_SUBEXPR (r->u.ss.start);
+ WALK_SUBEXPR (r->u.ss.end);
+ break;
+
+ case REF_COMPONENT:
+ break;
+ }
+ }
+
+ default:
+ break;
+ }
+ return 0;
}
-
- return;
+ return 0;
+}
+
+#define WALK_SUBCODE(NODE) \
+ do \
+ { \
+ result = gfc_code_walker (&(NODE), codefn, exprfn, data); \
+ if (result) \
+ return result; \
+ } \
+ while (0)
+
+/* Walk code *C, calling CODEFN on each gfc_code node in it and calling EXPRFN
+ on each expression in it. If any of the hooks returns non-zero, that
+ value is immediately returned. If the hook sets *WALK_SUBTREES to 0,
+ no subcodes or subexpressions are traversed. */
+
+int
+gfc_code_walker (gfc_code **c, walk_code_fn_t codefn, walk_expr_fn_t exprfn,
+ void *data)
+{
+ for (; *c; c = &(*c)->next)
+ {
+ int walk_subtrees = 1;
+ int result = codefn (c, &walk_subtrees, data);
+ if (result)
+ return result;
+
+ if (walk_subtrees)
+ {
+ gfc_code *b;
+ gfc_actual_arglist *a;
+ gfc_code *co;
+ gfc_association_list *alist;
+ bool saved_in_omp_workshare;
+
+ /* There might be statement insertions before the current code,
+ which must not affect the expression walker. */
+
+ co = *c;
+ saved_in_omp_workshare = in_omp_workshare;
+
+ switch (co->op)
+ {
+
+ case EXEC_BLOCK:
+ WALK_SUBCODE (co->ext.block.ns->code);
+ if (co->ext.block.assoc)
+ {
+ bool saved_in_assoc_list = in_assoc_list;
+
+ in_assoc_list = true;
+ for (alist = co->ext.block.assoc; alist; alist = alist->next)
+ WALK_SUBEXPR (alist->target);
+
+ in_assoc_list = saved_in_assoc_list;
+ }
+
+ break;
+
+ case EXEC_DO:
+ doloop_level ++;
+ WALK_SUBEXPR (co->ext.iterator->var);
+ WALK_SUBEXPR (co->ext.iterator->start);
+ WALK_SUBEXPR (co->ext.iterator->end);
+ WALK_SUBEXPR (co->ext.iterator->step);
+ break;
+
+ case EXEC_CALL:
+ case EXEC_ASSIGN_CALL:
+ for (a = co->ext.actual; a; a = a->next)
+ WALK_SUBEXPR (a->expr);
+ break;
+
+ case EXEC_CALL_PPC:
+ WALK_SUBEXPR (co->expr1);
+ for (a = co->ext.actual; a; a = a->next)
+ WALK_SUBEXPR (a->expr);
+ break;
+
+ case EXEC_SELECT:
+ WALK_SUBEXPR (co->expr1);
+ for (b = co->block; b; b = b->block)
+ {
+ gfc_case *cp;
+ for (cp = b->ext.block.case_list; cp; cp = cp->next)
+ {
+ WALK_SUBEXPR (cp->low);
+ WALK_SUBEXPR (cp->high);
+ }
+ WALK_SUBCODE (b->next);
+ }
+ continue;
+
+ case EXEC_ALLOCATE:
+ case EXEC_DEALLOCATE:
+ {
+ gfc_alloc *a;
+ for (a = co->ext.alloc.list; a; a = a->next)
+ WALK_SUBEXPR (a->expr);
+ break;
+ }
+
+ case EXEC_FORALL:
+ case EXEC_DO_CONCURRENT:
+ {
+ gfc_forall_iterator *fa;
+ for (fa = co->ext.forall_iterator; fa; fa = fa->next)
+ {
+ WALK_SUBEXPR (fa->var);
+ WALK_SUBEXPR (fa->start);
+ WALK_SUBEXPR (fa->end);
+ WALK_SUBEXPR (fa->stride);
+ }
+ if (co->op == EXEC_FORALL)
+ forall_level ++;
+ break;
+ }
+
+ case EXEC_OPEN:
+ WALK_SUBEXPR (co->ext.open->unit);
+ WALK_SUBEXPR (co->ext.open->file);
+ WALK_SUBEXPR (co->ext.open->status);
+ WALK_SUBEXPR (co->ext.open->access);
+ WALK_SUBEXPR (co->ext.open->form);
+ WALK_SUBEXPR (co->ext.open->recl);
+ WALK_SUBEXPR (co->ext.open->blank);
+ WALK_SUBEXPR (co->ext.open->position);
+ WALK_SUBEXPR (co->ext.open->action);
+ WALK_SUBEXPR (co->ext.open->delim);
+ WALK_SUBEXPR (co->ext.open->pad);
+ WALK_SUBEXPR (co->ext.open->iostat);
+ WALK_SUBEXPR (co->ext.open->iomsg);
+ WALK_SUBEXPR (co->ext.open->convert);
+ WALK_SUBEXPR (co->ext.open->decimal);
+ WALK_SUBEXPR (co->ext.open->encoding);
+ WALK_SUBEXPR (co->ext.open->round);
+ WALK_SUBEXPR (co->ext.open->sign);
+ WALK_SUBEXPR (co->ext.open->asynchronous);
+ WALK_SUBEXPR (co->ext.open->id);
+ WALK_SUBEXPR (co->ext.open->newunit);
+ break;
+
+ case EXEC_CLOSE:
+ WALK_SUBEXPR (co->ext.close->unit);
+ WALK_SUBEXPR (co->ext.close->status);
+ WALK_SUBEXPR (co->ext.close->iostat);
+ WALK_SUBEXPR (co->ext.close->iomsg);
+ break;
+
+ case EXEC_BACKSPACE:
+ case EXEC_ENDFILE:
+ case EXEC_REWIND:
+ case EXEC_FLUSH:
+ WALK_SUBEXPR (co->ext.filepos->unit);
+ WALK_SUBEXPR (co->ext.filepos->iostat);
+ WALK_SUBEXPR (co->ext.filepos->iomsg);
+ break;
+
+ case EXEC_INQUIRE:
+ WALK_SUBEXPR (co->ext.inquire->unit);
+ WALK_SUBEXPR (co->ext.inquire->file);
+ WALK_SUBEXPR (co->ext.inquire->iomsg);
+ WALK_SUBEXPR (co->ext.inquire->iostat);
+ WALK_SUBEXPR (co->ext.inquire->exist);
+ WALK_SUBEXPR (co->ext.inquire->opened);
+ WALK_SUBEXPR (co->ext.inquire->number);
+ WALK_SUBEXPR (co->ext.inquire->named);
+ WALK_SUBEXPR (co->ext.inquire->name);
+ WALK_SUBEXPR (co->ext.inquire->access);
+ WALK_SUBEXPR (co->ext.inquire->sequential);
+ WALK_SUBEXPR (co->ext.inquire->direct);
+ WALK_SUBEXPR (co->ext.inquire->form);
+ WALK_SUBEXPR (co->ext.inquire->formatted);
+ WALK_SUBEXPR (co->ext.inquire->unformatted);
+ WALK_SUBEXPR (co->ext.inquire->recl);
+ WALK_SUBEXPR (co->ext.inquire->nextrec);
+ WALK_SUBEXPR (co->ext.inquire->blank);
+ WALK_SUBEXPR (co->ext.inquire->position);
+ WALK_SUBEXPR (co->ext.inquire->action);
+ WALK_SUBEXPR (co->ext.inquire->read);
+ WALK_SUBEXPR (co->ext.inquire->write);
+ WALK_SUBEXPR (co->ext.inquire->readwrite);
+ WALK_SUBEXPR (co->ext.inquire->delim);
+ WALK_SUBEXPR (co->ext.inquire->encoding);
+ WALK_SUBEXPR (co->ext.inquire->pad);
+ WALK_SUBEXPR (co->ext.inquire->iolength);
+ WALK_SUBEXPR (co->ext.inquire->convert);
+ WALK_SUBEXPR (co->ext.inquire->strm_pos);
+ WALK_SUBEXPR (co->ext.inquire->asynchronous);
+ WALK_SUBEXPR (co->ext.inquire->decimal);
+ WALK_SUBEXPR (co->ext.inquire->pending);
+ WALK_SUBEXPR (co->ext.inquire->id);
+ WALK_SUBEXPR (co->ext.inquire->sign);
+ WALK_SUBEXPR (co->ext.inquire->size);
+ WALK_SUBEXPR (co->ext.inquire->round);
+ break;
+
+ case EXEC_WAIT:
+ WALK_SUBEXPR (co->ext.wait->unit);
+ WALK_SUBEXPR (co->ext.wait->iostat);
+ WALK_SUBEXPR (co->ext.wait->iomsg);
+ WALK_SUBEXPR (co->ext.wait->id);
+ break;
+
+ case EXEC_READ:
+ case EXEC_WRITE:
+ WALK_SUBEXPR (co->ext.dt->io_unit);
+ WALK_SUBEXPR (co->ext.dt->format_expr);
+ WALK_SUBEXPR (co->ext.dt->rec);
+ WALK_SUBEXPR (co->ext.dt->advance);
+ WALK_SUBEXPR (co->ext.dt->iostat);
+ WALK_SUBEXPR (co->ext.dt->size);
+ WALK_SUBEXPR (co->ext.dt->iomsg);
+ WALK_SUBEXPR (co->ext.dt->id);
+ WALK_SUBEXPR (co->ext.dt->pos);
+ WALK_SUBEXPR (co->ext.dt->asynchronous);
+ WALK_SUBEXPR (co->ext.dt->blank);
+ WALK_SUBEXPR (co->ext.dt->decimal);
+ WALK_SUBEXPR (co->ext.dt->delim);
+ WALK_SUBEXPR (co->ext.dt->pad);
+ WALK_SUBEXPR (co->ext.dt->round);
+ WALK_SUBEXPR (co->ext.dt->sign);
+ WALK_SUBEXPR (co->ext.dt->extra_comma);
+ break;
+
+ case EXEC_OMP_PARALLEL:
+ case EXEC_OMP_PARALLEL_DO:
+ case EXEC_OMP_PARALLEL_DO_SIMD:
+ case EXEC_OMP_PARALLEL_SECTIONS:
+
+ in_omp_workshare = false;
+
+ /* This goto serves as a shortcut to avoid code
+ duplication or a larger if or switch statement. */
+ goto check_omp_clauses;
+
+ case EXEC_OMP_WORKSHARE:
+ case EXEC_OMP_PARALLEL_WORKSHARE:
+
+ in_omp_workshare = true;
+
+ /* Fall through */
+
+ case EXEC_OMP_DISTRIBUTE:
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case EXEC_OMP_DISTRIBUTE_SIMD:
+ case EXEC_OMP_DO:
+ case EXEC_OMP_DO_SIMD:
+ case EXEC_OMP_SECTIONS:
+ case EXEC_OMP_SINGLE:
+ case EXEC_OMP_END_SINGLE:
+ case EXEC_OMP_SIMD:
+ case EXEC_OMP_TARGET:
+ case EXEC_OMP_TARGET_DATA:
+ case EXEC_OMP_TARGET_TEAMS:
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
+ case EXEC_OMP_TARGET_UPDATE:
+ case EXEC_OMP_TASK:
+ case EXEC_OMP_TEAMS:
+ case EXEC_OMP_TEAMS_DISTRIBUTE:
+ case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
+
+ /* Come to this label only from the
+ EXEC_OMP_PARALLEL_* cases above. */
+
+ check_omp_clauses:
+
+ if (co->ext.omp_clauses)
+ {
+ gfc_omp_namelist *n;
+ static int list_types[]
+ = { OMP_LIST_ALIGNED, OMP_LIST_LINEAR, OMP_LIST_DEPEND,
+ OMP_LIST_MAP, OMP_LIST_TO, OMP_LIST_FROM };
+ size_t idx;
+ WALK_SUBEXPR (co->ext.omp_clauses->if_expr);
+ WALK_SUBEXPR (co->ext.omp_clauses->final_expr);
+ WALK_SUBEXPR (co->ext.omp_clauses->num_threads);
+ WALK_SUBEXPR (co->ext.omp_clauses->chunk_size);
+ WALK_SUBEXPR (co->ext.omp_clauses->safelen_expr);
+ WALK_SUBEXPR (co->ext.omp_clauses->simdlen_expr);
+ WALK_SUBEXPR (co->ext.omp_clauses->num_teams);
+ WALK_SUBEXPR (co->ext.omp_clauses->device);
+ WALK_SUBEXPR (co->ext.omp_clauses->thread_limit);
+ WALK_SUBEXPR (co->ext.omp_clauses->dist_chunk_size);
+ for (idx = 0;
+ idx < sizeof (list_types) / sizeof (list_types[0]);
+ idx++)
+ for (n = co->ext.omp_clauses->lists[list_types[idx]];
+ n; n = n->next)
+ WALK_SUBEXPR (n->expr);
+ }
+ break;
+ default:
+ break;
+ }
+
+ WALK_SUBEXPR (co->expr1);
+ WALK_SUBEXPR (co->expr2);
+ WALK_SUBEXPR (co->expr3);
+ WALK_SUBEXPR (co->expr4);
+ for (b = co->block; b; b = b->block)
+ {
+ WALK_SUBEXPR (b->expr1);
+ WALK_SUBEXPR (b->expr2);
+ WALK_SUBCODE (b->next);
+ }
+
+ if (co->op == EXEC_FORALL)
+ forall_level --;
+
+ if (co->op == EXEC_DO)
+ doloop_level --;
+
+ in_omp_workshare = saved_in_omp_workshare;
+ }
+ }
+ return 0;
}