#include "gomp-constants.h"
#include "target-memory.h" /* For gfc_encode_character. */
#include "bitmap.h"
+#include "omp-api.h" /* For omp_runtime_api_procname. */
static gfc_statement omp_code_to_statement (gfc_code *);
gfc_error ("Object %qs is not a variable at %L", n->sym->name,
&n->where);
}
- if (omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]
- && code->op != EXEC_OMP_DO
- && code->op != EXEC_OMP_SIMD
- && code->op != EXEC_OMP_DO_SIMD
- && code->op != EXEC_OMP_PARALLEL_DO
- && code->op != EXEC_OMP_PARALLEL_DO_SIMD)
- gfc_error ("%<inscan%> REDUCTION clause on construct other than DO, SIMD, "
- "DO SIMD, PARALLEL DO, PARALLEL DO SIMD at %L",
- &omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where);
+ if (omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
+ {
+ locus *loc = &omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
+ if (code->op != EXEC_OMP_DO
+ && code->op != EXEC_OMP_SIMD
+ && code->op != EXEC_OMP_DO_SIMD
+ && code->op != EXEC_OMP_PARALLEL_DO
+ && code->op != EXEC_OMP_PARALLEL_DO_SIMD)
+ gfc_error ("%<inscan%> REDUCTION clause on construct other than DO, "
+ "SIMD, DO SIMD, PARALLEL DO, PARALLEL DO SIMD at %L",
+ loc);
+ if (omp_clauses->ordered)
+ gfc_error ("ORDERED clause specified together with %<inscan%> "
+ "REDUCTION clause at %L", loc);
+ if (omp_clauses->sched_kind != OMP_SCHED_NONE)
+ gfc_error ("SCHEDULE clause specified together with %<inscan%> "
+ "REDUCTION clause at %L", loc);
+ }
for (list = 0; list < OMP_LIST_NUM; list++)
if (list != OMP_LIST_FIRSTPRIVATE
static gfc_code *omp_current_do_code;
static int omp_current_do_collapse;
+/* Forward declaration for mutually recursive functions. */
+static gfc_code *
+find_nested_loop_in_block (gfc_code *block);
+
+/* Return the first nested DO loop in CHAIN, or NULL if there
+ isn't one. Does no error checking on intervening code. */
+
+static gfc_code *
+find_nested_loop_in_chain (gfc_code *chain)
+{
+ gfc_code *code;
+
+ if (!chain)
+ return NULL;
+
+ for (code = chain; code; code = code->next)
+ {
+ if (code->op == EXEC_DO)
+ return code;
+ else if (code->op == EXEC_BLOCK)
+ {
+ gfc_code *c = find_nested_loop_in_block (code);
+ if (c)
+ return c;
+ }
+ }
+ return NULL;
+}
+
+/* Return the first nested DO loop in BLOCK, or NULL if there
+ isn't one. Does no error checking on intervening code. */
+static gfc_code *
+find_nested_loop_in_block (gfc_code *block)
+{
+ gfc_namespace *ns;
+ gcc_assert (block->op == EXEC_BLOCK);
+ ns = block->ext.block.ns;
+ gcc_assert (ns);
+ return find_nested_loop_in_chain (ns->code);
+}
+
void
gfc_resolve_omp_do_blocks (gfc_code *code, gfc_namespace *ns)
{
if (code->block->next && code->block->next->op == EXEC_DO)
{
int i;
- gfc_code *c;
omp_current_do_code = code->block->next;
if (code->ext.omp_clauses->orderedc)
omp_current_do_collapse = code->ext.omp_clauses->orderedc;
- else
+ else if (code->ext.omp_clauses->collapse)
omp_current_do_collapse = code->ext.omp_clauses->collapse;
- for (i = 1, c = omp_current_do_code; i < omp_current_do_collapse; i++)
- {
- c = c->block;
- if (c->op != EXEC_DO || c->next == NULL)
- break;
- c = c->next;
- if (c->op != EXEC_DO)
- break;
- }
- if (i < omp_current_do_collapse || omp_current_do_collapse <= 0)
+ else
omp_current_do_collapse = 1;
if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
{
+ /* Checking that there is a matching EXEC_OMP_SCAN in the
+ innermost body cannot be deferred to resolve_omp_do because
+ we process directives nested in the loop before we get
+ there. */
locus *loc
= &code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN]->where;
- if (code->ext.omp_clauses->ordered)
- gfc_error ("ORDERED clause specified together with %<inscan%> "
- "REDUCTION clause at %L", loc);
- if (code->ext.omp_clauses->sched_kind != OMP_SCHED_NONE)
- gfc_error ("SCHEDULE clause specified together with %<inscan%> "
- "REDUCTION clause at %L", loc);
- gfc_code *block = c->block ? c->block->next : NULL;
- if (block && block->op != EXEC_OMP_SCAN)
- while (block && block->next && block->next->op != EXEC_OMP_SCAN)
- block = block->next;
- if (!block
- || (block->op != EXEC_OMP_SCAN
- && (!block->next || block->next->op != EXEC_OMP_SCAN)))
- gfc_error ("With INSCAN at %L, expected loop body with !$OMP SCAN "
- "between two structured block sequences", loc);
- else
+ gfc_code *c;
+
+ for (i = 1, c = omp_current_do_code;
+ i < omp_current_do_collapse; i++)
{
- if (block->op == EXEC_OMP_SCAN)
- gfc_warning (0, "!$OMP SCAN at %L with zero executable "
- "statements in preceding structured block "
- "sequence", &block->loc);
- if ((block->op == EXEC_OMP_SCAN && !block->next)
- || (block->next && block->next->op == EXEC_OMP_SCAN
- && !block->next->next))
- gfc_warning (0, "!$OMP SCAN at %L with zero executable "
- "statements in succeeding structured block "
- "sequence", block->op == EXEC_OMP_SCAN
- ? &block->loc : &block->next->loc);
- }
- if (block && block->op != EXEC_OMP_SCAN)
- block = block->next;
- if (block && block->op == EXEC_OMP_SCAN)
- /* Mark 'omp scan' as checked; flag will be unset later. */
- block->ext.omp_clauses->if_present = true;
+ c = find_nested_loop_in_chain (c->block->next);
+ if (!c || c->op != EXEC_DO || c->block == NULL)
+ break;
+ }
+
+ /* Skip this if we don't have enough nested loops. That
+ problem will be diagnosed elsewhere. */
+ if (c && c->op == EXEC_DO)
+ {
+ gfc_code *block = c->block ? c->block->next : NULL;
+ if (block && block->op != EXEC_OMP_SCAN)
+ while (block && block->next
+ && block->next->op != EXEC_OMP_SCAN)
+ block = block->next;
+ if (!block
+ || (block->op != EXEC_OMP_SCAN
+ && (!block->next || block->next->op != EXEC_OMP_SCAN)))
+ gfc_error ("With INSCAN at %L, expected loop body with "
+ "!$OMP SCAN between two "
+ "structured block sequences", loc);
+ else
+ {
+ if (block->op == EXEC_OMP_SCAN)
+ gfc_warning (0, "!$OMP SCAN at %L with zero executable "
+ "statements in preceding structured block "
+ "sequence", &block->loc);
+ if ((block->op == EXEC_OMP_SCAN && !block->next)
+ || (block->next && block->next->op == EXEC_OMP_SCAN
+ && !block->next->next))
+ gfc_warning (0, "!$OMP SCAN at %L with zero executable "
+ "statements in succeeding structured block "
+ "sequence", block->op == EXEC_OMP_SCAN
+ ? &block->loc : &block->next->loc);
+ }
+ if (block && block->op != EXEC_OMP_SCAN)
+ block = block->next;
+ if (block && block->op == EXEC_OMP_SCAN)
+ /* Mark 'omp scan' as checked; flag will be unset later. */
+ block->ext.omp_clauses->if_present = true;
+ }
}
}
gfc_resolve_blocks (code->block, ns);
private just in the !$omp do resp. !$omp parallel do construct,
with no implications for the outer parallel constructs. */
- while (i-- >= 1)
+ while (i-- >= 1 && c)
{
if (code == c)
return;
-
- c = c->block->next;
+ c = find_nested_loop_in_chain (c->block->next);
}
/* An openacc context may represent a data clause. Abort if so. */
gfc_traverse_ns (ns, handle_local_var);
}
+
+/* Error checking on intervening code uses a code walker. */
+
+struct icode_error_state
+{
+ const char *name;
+ bool errorp;
+ gfc_code *nested;
+ gfc_code *next;
+};
+
+static int
+icode_code_error_callback (gfc_code **codep,
+ int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque)
+{
+ gfc_code *code = *codep;
+ icode_error_state *state = (icode_error_state *)opaque;
+
+ /* gfc_code_walker walks down CODE's next chain as well as
+ walking things that are actually nested in CODE. We need to
+ special-case traversal of outer blocks, so stop immediately if we
+ are heading down such a next chain. */
+ if (code == state->next)
+ return 1;
+
+ switch (code->op)
+ {
+ case EXEC_DO:
+ case EXEC_DO_WHILE:
+ case EXEC_DO_CONCURRENT:
+ gfc_error ("%s cannot contain loop in intervening code at %L",
+ state->name, &code->loc);
+ state->errorp = true;
+ break;
+ case EXEC_CYCLE:
+ case EXEC_EXIT:
+ /* Errors have already been diagnosed in match_exit_cycle. */
+ state->errorp = true;
+ break;
+ case EXEC_OMP_CRITICAL:
+ case EXEC_OMP_DO:
+ case EXEC_OMP_FLUSH:
+ 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_WORKSHARE:
+ case EXEC_OMP_ATOMIC:
+ case EXEC_OMP_BARRIER:
+ case EXEC_OMP_END_NOWAIT:
+ case EXEC_OMP_END_SINGLE:
+ case EXEC_OMP_TASK:
+ case EXEC_OMP_TASKWAIT:
+ case EXEC_OMP_TASKYIELD:
+ case EXEC_OMP_CANCEL:
+ case EXEC_OMP_CANCELLATION_POINT:
+ case EXEC_OMP_TASKGROUP:
+ case EXEC_OMP_SIMD:
+ case EXEC_OMP_DO_SIMD:
+ case EXEC_OMP_PARALLEL_DO_SIMD:
+ case EXEC_OMP_TARGET:
+ case EXEC_OMP_TARGET_DATA:
+ case EXEC_OMP_TEAMS:
+ case EXEC_OMP_DISTRIBUTE:
+ case EXEC_OMP_DISTRIBUTE_SIMD:
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
+ case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case EXEC_OMP_TARGET_TEAMS:
+ case EXEC_OMP_TEAMS_DISTRIBUTE:
+ case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
+ case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
+ case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+ case EXEC_OMP_TARGET_UPDATE:
+ case EXEC_OMP_END_CRITICAL:
+ case EXEC_OMP_TARGET_ENTER_DATA:
+ case EXEC_OMP_TARGET_EXIT_DATA:
+ case EXEC_OMP_TARGET_PARALLEL:
+ case EXEC_OMP_TARGET_PARALLEL_DO:
+ case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
+ case EXEC_OMP_TARGET_SIMD:
+ case EXEC_OMP_TASKLOOP:
+ case EXEC_OMP_TASKLOOP_SIMD:
+ case EXEC_OMP_SCAN:
+ case EXEC_OMP_DEPOBJ:
+ case EXEC_OMP_PARALLEL_MASTER:
+ case EXEC_OMP_PARALLEL_MASTER_TASKLOOP:
+ case EXEC_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
+ case EXEC_OMP_MASTER_TASKLOOP:
+ case EXEC_OMP_MASTER_TASKLOOP_SIMD:
+ case EXEC_OMP_LOOP:
+ case EXEC_OMP_PARALLEL_LOOP:
+ case EXEC_OMP_TEAMS_LOOP:
+ case EXEC_OMP_TARGET_PARALLEL_LOOP:
+ case EXEC_OMP_TARGET_TEAMS_LOOP:
+ case EXEC_OMP_MASKED:
+ case EXEC_OMP_PARALLEL_MASKED:
+ case EXEC_OMP_PARALLEL_MASKED_TASKLOOP:
+ case EXEC_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
+ case EXEC_OMP_MASKED_TASKLOOP:
+ case EXEC_OMP_MASKED_TASKLOOP_SIMD:
+ case EXEC_OMP_SCOPE:
+ case EXEC_OMP_ERROR:
+ gfc_error ("%s cannot contain OpenMP directive in intervening code "
+ "at %L",
+ state->name, &code->loc);
+ state->errorp = true;
+ break;
+ case EXEC_CALL:
+ /* Per OpenMP 5.2, the "omp_" prefix is reserved, so we don't have to
+ consider the possibility that some locally-bound definition
+ overrides the runtime routine. */
+ if (code->resolved_sym
+ && omp_runtime_api_procname (code->resolved_sym->name))
+ {
+ gfc_error ("%s cannot contain OpenMP API call in intervening code "
+ "at %L",
+ state->name, &code->loc);
+ state->errorp = true;
+ }
+ break;
+ default:
+ break;
+ }
+ return 0;
+}
+
+static int
+icode_expr_error_callback (gfc_expr **expr,
+ int *walk_subtrees ATTRIBUTE_UNUSED, void *opaque)
+{
+ icode_error_state *state = (icode_error_state *)opaque;
+
+ switch ((*expr)->expr_type)
+ {
+ /* As for EXPR_CALL with "omp_"-prefixed symbols. */
+ case EXPR_FUNCTION:
+ {
+ gfc_symbol *sym = (*expr)->value.function.esym;
+ if (sym && omp_runtime_api_procname (sym->name))
+ {
+ gfc_error ("%s cannot contain OpenMP API call in intervening code "
+ "at %L",
+ state->name, &((*expr)->where));
+ state->errorp = true;
+ }
+ }
+
+ break;
+ default:
+ break;
+ }
+
+ /* FIXME: The description of canonical loop form in the OpenMP standard
+ also says "array expressions" are not permitted in intervening code.
+ That term is not defined in either the OpenMP spec or the Fortran
+ standard, although the latter uses it informally to refer to any
+ expression that is not scalar-valued. It is also apparently not the
+ thing GCC internally calls EXPR_ARRAY. It seems the intent of the
+ OpenMP restriction is to disallow elemental operations/intrinsics
+ (including things that are not expressions, like assignment
+ statements) that generate implicit loops over array operands
+ (even if the result is a scalar), but even if the spec said
+ that there is no list of all the cases that would be forbidden.
+ This is OpenMP issue 3326. */
+
+ return 0;
+}
+
+static void
+diagnose_intervening_code_errors_1 (gfc_code *chain,
+ struct icode_error_state *state)
+{
+ gfc_code *code;
+ for (code = chain; code; code = code->next)
+ {
+ if (code == state->nested)
+ /* Do not walk the nested loop or its body, we are only
+ interested in intervening code. */
+ ;
+ else if (code->op == EXEC_BLOCK
+ && find_nested_loop_in_block (code) == state->nested)
+ /* This block contains the nested loop, recurse on its
+ statements. */
+ {
+ gfc_namespace* ns = code->ext.block.ns;
+ diagnose_intervening_code_errors_1 (ns->code, state);
+ }
+ else
+ /* Treat the whole statement as a unit. */
+ {
+ gfc_code *temp = state->next;
+ state->next = code->next;
+ gfc_code_walker (&code, icode_code_error_callback,
+ icode_expr_error_callback, state);
+ state->next = temp;
+ }
+ }
+}
+
+/* Diagnose intervening code errors in BLOCK with nested loop NESTED.
+ NAME is the user-friendly name of the OMP directive, used for error
+ messages. Returns true if any error was found. */
+static bool
+diagnose_intervening_code_errors (gfc_code *chain, const char *name,
+ gfc_code *nested)
+{
+ struct icode_error_state state;
+ state.name = name;
+ state.errorp = false;
+ state.nested = nested;
+ state.next = NULL;
+ diagnose_intervening_code_errors_1 (chain, &state);
+ return state.errorp;
+}
+
+/* Helper function for restructure_intervening_code: wrap CHAIN in
+ a marker to indicate that it is a structured block sequence. That
+ information will be used later on (in omp-low.cc) for error checking. */
+static gfc_code *
+make_structured_block (gfc_code *chain)
+{
+ gcc_assert (chain);
+ gfc_namespace *ns = gfc_build_block_ns (gfc_current_ns);
+ gfc_code *result = gfc_get_code (EXEC_BLOCK);
+ result->op = EXEC_BLOCK;
+ result->ext.block.ns = ns;
+ result->ext.block.assoc = NULL;
+ result->loc = chain->loc;
+ ns->omp_structured_block = 1;
+ ns->code = chain;
+ return result;
+}
+
+/* Push intervening code surrounding a loop, including nested scopes,
+ into the body of the loop. CHAINP is the pointer to the head of
+ the next-chain to scan, OUTER_LOOP is the EXEC_DO for the next outer
+ loop level, and COLLAPSE is the number of nested loops we need to
+ process.
+ Note that CHAINP may point at outer_loop->block->next when we
+ are scanning the body of a loop, but if there is an intervening block
+ CHAINP points into the block's chain rather than its enclosing outer
+ loop. This is why OUTER_LOOP is passed separately. */
+static gfc_code *
+restructure_intervening_code (gfc_code **chainp, gfc_code *outer_loop,
+ int count)
+{
+ gfc_code *code;
+ gfc_code *head = *chainp;
+ gfc_code *tail = NULL;
+ gfc_code *innermost_loop = NULL;
+
+ for (code = *chainp; code; code = code->next, chainp = &((*chainp)->next))
+ {
+ if (code->op == EXEC_DO)
+ {
+ /* Cut CODE free from its chain, leaving the ends dangling. */
+ *chainp = NULL;
+ tail = code->next;
+ code->next = NULL;
+
+ if (count == 1)
+ innermost_loop = code;
+ else
+ innermost_loop
+ = restructure_intervening_code (&(code->block->next),
+ code, count - 1);
+ break;
+ }
+ else if (code->op == EXEC_BLOCK
+ && find_nested_loop_in_block (code))
+ {
+ gfc_namespace *ns = code->ext.block.ns;
+
+ /* Cut CODE free from its chain, leaving the ends dangling. */
+ *chainp = NULL;
+ tail = code->next;
+ code->next = NULL;
+
+ innermost_loop
+ = restructure_intervening_code (&(ns->code), outer_loop,
+ count);
+
+ /* At this point we have already pulled out the nested loop and
+ pointed outer_loop at it, and moved the intervening code that
+ was previously in the block into the body of innermost_loop.
+ Now we want to move the BLOCK itself so it wraps the entire
+ current body of innermost_loop. */
+ ns->code = innermost_loop->block->next;
+ innermost_loop->block->next = code;
+ break;
+ }
+ }
+
+ gcc_assert (innermost_loop);
+
+ /* Now we have split the intervening code into two parts:
+ head is the start of the part before the loop/block, terminating
+ at *chainp, and tail is the part after it. Mark each part as
+ a structured block sequence, and splice the two parts around the
+ existing body of the innermost loop. */
+ if (head != code)
+ {
+ gfc_code *block = make_structured_block (head);
+ if (innermost_loop->block->next)
+ gfc_append_code (block, innermost_loop->block->next);
+ innermost_loop->block->next = block;
+ }
+ if (tail)
+ {
+ gfc_code *block = make_structured_block (tail);
+ if (innermost_loop->block->next)
+ gfc_append_code (innermost_loop->block->next, block);
+ else
+ innermost_loop->block->next = block;
+ }
+
+ /* For loops, finally splice CODE into OUTER_LOOP. We already handled
+ relinking EXEC_BLOCK above. */
+ if (code->op == EXEC_DO && outer_loop)
+ outer_loop->block->next = code;
+
+ return innermost_loop;
+}
+
/* CODE is an OMP loop construct. Return true if VAR matches an iteration
variable outer to level DEPTH. */
static bool
is_outer_iteration_variable (gfc_code *code, int depth, gfc_symbol *var)
{
int i;
- gfc_code *do_code = code->block->next;
+ gfc_code *do_code = code;
for (i = 1; i < depth; i++)
{
+ do_code = find_nested_loop_in_chain (do_code->block->next);
+ gcc_assert (do_code);
gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
if (var == ivar)
return true;
- do_code = do_code->block->next;
+ }
+ return false;
+}
+
+/* Forward declaration for recursive functions. */
+static gfc_code *
+check_nested_loop_in_block (gfc_code *block, gfc_expr *expr, gfc_symbol *sym,
+ bool *bad);
+
+/* Like find_nested_loop_in_chain, but additionally check that EXPR
+ does not reference any variables bound in intervening EXEC_BLOCKs
+ and that SYM is not bound in such intervening blocks. Either EXPR or SYM
+ may be null. Sets *BAD to true if either test fails. */
+static gfc_code *
+check_nested_loop_in_chain (gfc_code *chain, gfc_expr *expr, gfc_symbol *sym,
+ bool *bad)
+{
+ for (gfc_code *code = chain; code; code = code->next)
+ {
+ if (code->op == EXEC_DO)
+ return code;
+ else if (code->op == EXEC_BLOCK)
+ {
+ gfc_code *c = check_nested_loop_in_block (code, expr, sym, bad);
+ if (c)
+ return c;
+ }
+ }
+ return NULL;
+}
+
+/* Code walker for block symtrees. It doesn't take any kind of state
+ argument, so use a static variable. */
+static struct check_nested_loop_in_block_state_t {
+ gfc_expr *expr;
+ gfc_symbol *sym;
+ bool *bad;
+} check_nested_loop_in_block_state;
+
+static void
+check_nested_loop_in_block_symbol (gfc_symbol *sym)
+{
+ if (sym == check_nested_loop_in_block_state.sym
+ || (check_nested_loop_in_block_state.expr
+ && gfc_find_sym_in_expr (sym,
+ check_nested_loop_in_block_state.expr)))
+ *check_nested_loop_in_block_state.bad = true;
+}
+
+/* Return the first nested DO loop in BLOCK, or NULL if there
+ isn't one. Set *BAD to true if EXPR references any variables in BLOCK, or
+ SYM is bound in BLOCK. Either EXPR or SYM may be null. */
+static gfc_code *
+check_nested_loop_in_block (gfc_code *block, gfc_expr *expr,
+ gfc_symbol *sym, bool *bad)
+{
+ gfc_namespace *ns;
+ gcc_assert (block->op == EXEC_BLOCK);
+ ns = block->ext.block.ns;
+ gcc_assert (ns);
+
+ /* Skip the check if this block doesn't contain the nested loop, or
+ if we already know it's bad. */
+ gfc_code *result = check_nested_loop_in_chain (ns->code, expr, sym, bad);
+ if (result && !*bad)
+ {
+ check_nested_loop_in_block_state.expr = expr;
+ check_nested_loop_in_block_state.sym = sym;
+ check_nested_loop_in_block_state.bad = bad;
+ gfc_traverse_ns (ns, check_nested_loop_in_block_symbol);
+ check_nested_loop_in_block_state.expr = NULL;
+ check_nested_loop_in_block_state.sym = NULL;
+ check_nested_loop_in_block_state.bad = NULL;
+ }
+ return result;
+}
+
+/* CODE is an OMP loop construct. Return true if EXPR references
+ any variables bound in intervening code, to level DEPTH. */
+static bool
+expr_uses_intervening_var (gfc_code *code, int depth, gfc_expr *expr)
+{
+ int i;
+ gfc_code *do_code = code;
+
+ for (i = 0; i < depth; i++)
+ {
+ bool bad = false;
+ do_code = check_nested_loop_in_chain (do_code->block->next,
+ expr, NULL, &bad);
+ if (bad)
+ return true;
+ }
+ return false;
+}
+
+/* CODE is an OMP loop construct. Return true if SYM is bound in
+ intervening code, to level DEPTH. */
+static bool
+is_intervening_var (gfc_code *code, int depth, gfc_symbol *sym)
+{
+ int i;
+ gfc_code *do_code = code;
+
+ for (i = 0; i < depth; i++)
+ {
+ bool bad = false;
+ do_code = check_nested_loop_in_chain (do_code->block->next,
+ NULL, sym, &bad);
+ if (bad)
+ return true;
}
return false;
}
expr_is_invariant (gfc_code *code, int depth, gfc_expr *expr)
{
int i;
- gfc_code *do_code = code->block->next;
+ gfc_code *do_code = code;
for (i = 1; i < depth; i++)
{
+ do_code = find_nested_loop_in_chain (do_code->block->next);
+ gcc_assert (do_code);
gfc_symbol *ivar = do_code->ext.iterator->var->symtree->n.sym;
if (gfc_find_sym_in_expr (ivar, expr))
return false;
- do_code = do_code->block->next;
}
return true;
}
static void
resolve_omp_do (gfc_code *code)
{
- gfc_code *do_code, *c;
- int list, i, collapse;
+ gfc_code *do_code, *next;
+ int list, i, count;
gfc_omp_namelist *n;
gfc_symbol *dovar;
const char *name;
bool is_simd = false;
+ bool errorp = false;
+ bool perfect_nesting_errorp = false;
switch (code->op)
{
do_code = code->block->next;
if (code->ext.omp_clauses->orderedc)
- collapse = code->ext.omp_clauses->orderedc;
+ count = code->ext.omp_clauses->orderedc;
else
{
- collapse = code->ext.omp_clauses->collapse;
- if (collapse <= 0)
- collapse = 1;
+ count = code->ext.omp_clauses->collapse;
+ if (count <= 0)
+ count = 1;
}
/* While the spec defines the loop nest depth independently of the COLLAPSE
depth and treats any further inner loops as the final-loop-body. So
here we also check canonical loop nest form only for the number of
outer loops specified by the COLLAPSE clause too. */
- for (i = 1; i <= collapse; i++)
+ for (i = 1; i <= count; i++)
{
gfc_symbol *start_var = NULL, *end_var = NULL;
+ /* Parse errors are not recoverable. */
if (do_code->op == EXEC_DO_WHILE)
{
gfc_error ("%s cannot be a DO WHILE or DO without loop control "
"at %L", name, &do_code->loc);
- break;
+ return;
}
if (do_code->op == EXEC_DO_CONCURRENT)
{
gfc_error ("%s cannot be a DO CONCURRENT loop at %L", name,
&do_code->loc);
- break;
+ return;
}
gcc_assert (do_code->op == EXEC_DO);
if (do_code->ext.iterator->var->ts.type != BT_INTEGER)
- gfc_error ("%s iteration variable must be of type integer at %L",
- name, &do_code->loc);
+ {
+ gfc_error ("%s iteration variable must be of type integer at %L",
+ name, &do_code->loc);
+ errorp = true;
+ }
dovar = do_code->ext.iterator->var->symtree->n.sym;
if (dovar->attr.threadprivate)
- gfc_error ("%s iteration variable must not be THREADPRIVATE "
- "at %L", name, &do_code->loc);
+ {
+ gfc_error ("%s iteration variable must not be THREADPRIVATE "
+ "at %L", name, &do_code->loc);
+ errorp = true;
+ }
if (code->ext.omp_clauses)
for (list = 0; list < OMP_LIST_NUM; list++)
if (!is_simd || code->ext.omp_clauses->collapse > 1
gfc_error ("%s iteration variable present on clause "
"other than PRIVATE, LASTPRIVATE, ALLOCATE or "
"LINEAR at %L", name, &do_code->loc);
- break;
+ errorp = true;
}
if (is_outer_iteration_variable (code, i, dovar))
{
gfc_error ("%s iteration variable used in more than one loop at %L",
name, &do_code->loc);
- break;
+ errorp = true;
+ }
+ else if (is_intervening_var (code, i, dovar))
+ {
+ gfc_error ("%s iteration variable at %L is bound in "
+ "intervening code",
+ name, &do_code->loc);
+ errorp = true;
}
else if (!bound_expr_is_canonical (code, i,
do_code->ext.iterator->start,
{
gfc_error ("%s loop start expression not in canonical form at %L",
name, &do_code->loc);
- break;
+ errorp = true;
+ }
+ else if (expr_uses_intervening_var (code, i,
+ do_code->ext.iterator->start))
+ {
+ gfc_error ("%s loop start expression at %L uses variable bound in "
+ "intervening code",
+ name, &do_code->loc);
+ errorp = true;
}
else if (!bound_expr_is_canonical (code, i,
do_code->ext.iterator->end,
{
gfc_error ("%s loop end expression not in canonical form at %L",
name, &do_code->loc);
- break;
+ errorp = true;
+ }
+ else if (expr_uses_intervening_var (code, i,
+ do_code->ext.iterator->end))
+ {
+ gfc_error ("%s loop end expression at %L uses variable bound in "
+ "intervening code",
+ name, &do_code->loc);
+ errorp = true;
}
else if (start_var && end_var && start_var != end_var)
{
gfc_error ("%s loop bounds reference different "
"iteration variables at %L", name, &do_code->loc);
- break;
+ errorp = true;
}
else if (!expr_is_invariant (code, i, do_code->ext.iterator->step))
{
gfc_error ("%s loop increment not in canonical form at %L",
name, &do_code->loc);
- break;
+ errorp = true;
+ }
+ else if (expr_uses_intervening_var (code, i,
+ do_code->ext.iterator->step))
+ {
+ gfc_error ("%s loop increment expression at %L uses variable "
+ "bound in intervening code",
+ name, &do_code->loc);
+ errorp = true;
}
if (start_var || end_var)
code->ext.omp_clauses->non_rectangular = 1;
- for (c = do_code->next; c; c = c->next)
- if (c->op != EXEC_NOP && c->op != EXEC_CONTINUE)
- {
- gfc_error ("collapsed %s loops not perfectly nested at %L",
- name, &c->loc);
- break;
- }
- if (i == collapse || c)
+ /* Only parse loop body into nested loop and intervening code if
+ there are supposed to be more loops in the nest to collapse. */
+ if (i == count)
break;
- do_code = do_code->block;
- if (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE)
+
+ next = find_nested_loop_in_chain (do_code->block->next);
+
+ if (!next)
{
- gfc_error ("not enough DO loops for collapsed %s at %L",
- name, &code->loc);
- break;
+ /* Parse error, can't recover from this. */
+ gfc_error ("not enough DO loops for collapsed %s (level %d) at %L",
+ name, i, &code->loc);
+ return;
}
- do_code = do_code->next;
- if (do_code == NULL
- || (do_code->op != EXEC_DO && do_code->op != EXEC_DO_WHILE))
+ else if (next != do_code->block->next || next->next)
+ /* Imperfectly nested loop found. */
{
- gfc_error ("not enough DO loops for collapsed %s at %L",
- name, &code->loc);
- break;
+ /* Only diagnose violation of imperfect nesting constraints once. */
+ if (!perfect_nesting_errorp)
+ {
+ if (code->ext.omp_clauses->orderedc)
+ {
+ gfc_error ("%s inner loops must be perfectly nested with "
+ "ORDERED clause at %L",
+ name, &code->loc);
+ perfect_nesting_errorp = true;
+ }
+ else if (code->ext.omp_clauses->lists[OMP_LIST_REDUCTION_INSCAN])
+ {
+ gfc_error ("%s inner loops must be perfectly nested with "
+ "REDUCTION INSCAN clause at %L",
+ name, &code->loc);
+ perfect_nesting_errorp = true;
+ }
+ /* FIXME: Also diagnose for TILE directives. */
+ if (perfect_nesting_errorp)
+ errorp = true;
+ }
+ if (diagnose_intervening_code_errors (do_code->block->next,
+ name, next))
+ errorp = true;
}
+ do_code = next;
}
+
+ /* Give up now if we found any constraint violations. */
+ if (errorp)
+ return;
+
+ restructure_intervening_code (&(code->block->next), code, count);
}
projects / thirdparty / gcc.git / commitdiff
