@@ -30,6 +30,7 @@ along with GCC; see the file COPYING3. If not see
#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 *);
@@ -7209,15 +7210,24 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
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
@@ -9033,68 +9043,114 @@ static struct fortran_omp_context
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);
@@ -9224,13 +9280,12 @@ gfc_resolve_do_iterator (gfc_code *code, gfc_symbol *sym, bool add_clause)
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. */
if (!omp_current_ctx->is_openmp && !oacc_is_loop (omp_current_ctx->code))
@@ -9269,20 +9324,332 @@ gfc_resolve_omp_local_vars (gfc_namespace *ns)
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 OMP 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 OMP 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 OMP 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;
+}
+
+/* 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 collapse)
+{
+ 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 (collapse == 1)
+ innermost_loop = code;
+ else
+ innermost_loop
+ = restructure_intervening_code (&(code->block->next),
+ code, collapse - 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,
+ collapse);
+
+ /* 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. Splice the two parts
+ around the existing body of the innermost loop. */
+ if (head != code)
+ {
+ if (innermost_loop->block->next)
+ gfc_append_code (head, innermost_loop->block->next);
+ innermost_loop->block->next = head;
+ }
+ if (tail)
+ {
+ if (innermost_loop->block->next)
+ gfc_append_code (innermost_loop->block->next, tail);
+ else
+ innermost_loop->block->next = tail;
+ }
+
+ /* 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;
}
@@ -9293,14 +9660,15 @@ static bool
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;
}
@@ -9371,12 +9739,14 @@ bound_expr_is_canonical (gfc_code *code, int depth, gfc_expr *expr,
static void
resolve_omp_do (gfc_code *code)
{
- gfc_code *do_code, *c;
+ gfc_code *do_code, *next;
int list, i, collapse;
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)
{
@@ -9495,26 +9865,33 @@ resolve_omp_do (gfc_code *code)
for (i = 1; i <= collapse; 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
@@ -9533,13 +9910,13 @@ resolve_omp_do (gfc_code *code)
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 (!bound_expr_is_canonical (code, i,
do_code->ext.iterator->start,
@@ -9547,7 +9924,7 @@ resolve_omp_do (gfc_code *code)
{
gfc_error ("%s loop start expression not in canonical form at %L",
name, &do_code->loc);
- break;
+ errorp = true;
}
else if (!bound_expr_is_canonical (code, i,
do_code->ext.iterator->end,
@@ -9555,48 +9932,73 @@ resolve_omp_do (gfc_code *code)
{
gfc_error ("%s loop end expression not in canonical form at %L",
name, &do_code->loc);
- break;
+ 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;
}
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 == collapse)
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, collapse);
}
@@ -31,11 +31,11 @@ subroutine collapse1
do i = 1, 3
do j = 4, 6
end do
- k = 4 ! { dg-error "loops not perfectly nested" }
+ k = 4
end do
- !$omp parallel do collapse(2)
+ !$omp parallel do collapse(2) ! { dg-error "not enough DO loops" }
do i = 1, 3
- do ! { dg-error "cannot be a DO WHILE or DO without loop control" }
+ do
end do
end do
!$omp parallel do collapse(2)
@@ -6,24 +6,24 @@ program p
do j = 1, 8
do k = 1, 8
end do
- x = 5 ! { dg-error "loops not perfectly nested" }
+ x = 5
end do
end do
- !$omp parallel do ordered(3)
+ !$omp parallel do ordered(3) ! { dg-error "inner loops must be perfectly nested" }
do i = 1, 8
do j = 1, 8
do k = 1, 8
end do
end do
- x = 5 ! { dg-error "loops not perfectly nested" }
+ x = 5
end do
- !$omp parallel do collapse(2) ! { dg-error "not enough DO loops for collapsed" }
+ !$omp parallel do collapse(2)
do i = 1, 8
x = 5
do j = 1, 8
end do
end do
- !$omp parallel do ordered(2) ! { dg-error "not enough DO loops for collapsed" }
+ !$omp parallel do ordered(2) ! { dg-error "inner loops must be perfectly nested" }
do i = 1, 8
x = 5
do j = 1, 8
new file mode 100644
@@ -0,0 +1,39 @@
+! This test case is expected to fail due to errors.
+
+subroutine f1 (depth, iter)
+ integer :: depth, iter
+end subroutine
+
+subroutine f2 (depth, iter)
+ integer :: depth, iter
+end subroutine
+
+subroutine s1 (a1, a2, a3)
+ integer :: a1, a2, a3
+ integer :: i, j, k
+
+ !$omp do collapse(3)
+ do i = 1, a1
+ call f1 (1, i)
+ do j = 1, a2
+ call f1 (2, j)
+ if (i == 3) then
+ cycle ! { dg-error "CYCLE statement" }
+ else
+ exit ! { dg-error "EXIT statement" }
+ endif
+!$omp barrier ! { dg-error "OMP directive in intervening code" }
+ do k = 1, a3
+ call f1 (3, k)
+ call f2 (3, k)
+ end do
+ call f2 (2, j)
+ end do
+ do k = 1, a3 ! { dg-error "loop in intervening code" }
+ call f1 (3, k)
+ call f2 (3, k)
+ end do
+ call f2 (1, i)
+ end do
+
+end subroutine
new file mode 100644
@@ -0,0 +1,56 @@
+! This test case is expected to fail due to errors.
+
+! Note that the calls to these functions in the test case don't make
+! any sense in terms of behavior, they're just there to test the error
+! behavior.
+
+module omp_lib
+ use iso_c_binding
+ interface
+ integer function omp_get_thread_num ()
+ end
+ subroutine omp_set_max_levels (i)
+ integer :: i
+ end
+ end interface
+end module
+
+program junk
+ use omp_lib
+ implicit none
+
+contains
+
+subroutine f1 (depth, iter)
+ integer :: depth, iter
+end subroutine
+
+subroutine f2 (depth, iter)
+ integer :: depth, iter
+end subroutine
+
+subroutine s1 (a1, a2, a3)
+ integer :: a1, a2, a3
+ integer :: i, j, k
+
+ integer :: m
+
+ !$omp do collapse(3)
+ do i = 1, a1
+ call f1 (1, i)
+ m = omp_get_thread_num () ! { dg-error "OMP API call in intervening code" }
+ do j = 1, a2 + omp_get_thread_num () ! This is OK
+ call f1 (2, j)
+ do k = 1, a3
+ call f1 (m, k)
+ call omp_set_max_active_levels (k) ! This is OK too
+ call f2 (m, k)
+ end do
+ call f2 (2, j)
+ call omp_set_max_active_levels (i) ! { dg-error "OMP API call in intervening code" }
+ end do
+ call f2 (1, i)
+ end do
+end subroutine
+
+end program
new file mode 100644
@@ -0,0 +1,29 @@
+! This test case is expected to fail due to errors.
+
+subroutine f1 (depth, iter)
+ integer :: depth, iter
+end subroutine
+
+subroutine f2 (depth, iter)
+ integer :: depth, iter
+end subroutine
+
+subroutine s1 (a1, a2, a3)
+ integer :: a1, a2, a3
+ integer :: i, j, k
+
+ !$omp do ordered(3) ! { dg-error "inner loops must be perfectly nested" }
+ do i = 1, a1
+ call f1 (1, i)
+ do j = 1, a2
+ call f1 (2, j)
+ do k = 1, a3
+ call f1 (3, k)
+ call f2 (3, k)
+ end do
+ call f2 (2, j)
+ end do
+ call f2 (1, i)
+ end do
+
+end subroutine
new file mode 100644
@@ -0,0 +1,36 @@
+! This test case is expected to fail due to errors.
+
+subroutine f1 (depth, iter)
+ integer :: depth, iter
+end subroutine
+
+subroutine f2 (depth, iter)
+ integer :: depth, iter
+end subroutine
+
+! Unlike the C/C++ front ends, the Fortran front end already has the whole
+! parse tree for the OMP DO construct before doing error checking on it.
+! It gives up immediately if there are not enough nested loops for the
+! specified COLLAPSE depth, without error-checking intervening code.
+
+subroutine s1 (a1, a2, a3)
+ integer :: a1, a2, a3
+ integer :: i, j, k
+
+ !$omp do collapse(4) ! { dg-error "not enough DO loops" }
+ do i = 1, a1
+ call f1 (1, i)
+ do j = 1, a2
+ call f1 (2, j)
+ do k = 1, a3
+! This is not valid intervening code, but the above error takes precedence.
+!$omp barrier
+ call f1 (3, k)
+ call f2 (3, k)
+ end do
+ call f2 (2, j)
+ end do
+ call f2 (1, i)
+ end do
+
+end subroutine
new file mode 100644
@@ -0,0 +1,67 @@
+! This test case is expected to fail due to errors.
+
+subroutine f1 (depth, iter)
+ integer :: depth, iter
+end subroutine
+
+subroutine f2 (depth, iter)
+ integer :: depth, iter
+end subroutine
+
+function ijk (x, y, z)
+ integer :: ijk
+ integer :: x, y, z
+end function
+
+subroutine f3 (sum)
+ integer :: sum
+end subroutine
+
+! This function isn't particularly meaningful, but it should compile without
+! error.
+function s1 (a1, a2, a3)
+ integer :: s1
+ integer :: a1, a2, a3
+ integer :: i, j, k
+ integer :: r
+
+ r = 0
+ !$omp simd collapse(3) reduction (inscan, +:r)
+ do i = 1, a1
+ do j = 1, a2
+ do k = 1, a3
+ r = r + ijk (i, j, k)
+!$omp scan exclusive (r)
+ call f3 (r)
+ end do
+ end do
+ end do
+
+ s1 = r
+end function
+
+! Adding intervening code should trigger an error.
+function s2 (a1, a2, a3)
+ integer :: s2
+ integer :: a1, a2, a3
+ integer :: i, j, k
+ integer :: r
+
+ r = 0
+ !$omp simd collapse(3) reduction (inscan, +:r) ! { dg-error "inner loops must be perfectly nested" }
+ do i = 1, a1
+ call f1 (1, i)
+ do j = 1, a2
+ call f1 (2, j)
+ do k = 1, a3
+ r = r + ijk (i, j, k)
+!$omp scan exclusive (r)
+ call f3 (r)
+ end do
+ call f2 (2, j)
+ end do
+ call f2 (1, i)
+ end do
+
+ s2 = r
+end function
new file mode 100644
@@ -0,0 +1,142 @@
+! { dg-do run }
+
+! Like imperfect2.f90, but adds bindings to the blocks.
+
+module m
+ implicit none
+ type t
+ integer :: i
+ contains
+ final :: fini
+ end type t
+
+ integer :: ccount(3), dcount(3)
+
+ contains
+
+ subroutine init(x, n)
+ type(t) :: x
+ integer :: n
+ x%i = n
+ ccount(x%i) = ccount(x%i) + 1
+ end subroutine init
+
+ subroutine fini(x)
+ type(t) :: x
+ dcount(x%i) = dcount(x%i) + 1
+ end subroutine fini
+end module m
+
+program foo
+ use m
+
+ integer :: f1count(3), f2count(3), g1count(3), g2count(3)
+
+ f1count(1) = 0
+ f1count(2) = 0
+ f1count(3) = 0
+ f2count(1) = 0
+ f2count(2) = 0
+ f2count(3) = 0
+
+ g1count(1) = 0
+ g1count(2) = 0
+ g1count(3) = 0
+ g2count(1) = 0
+ g2count(2) = 0
+ g2count(3) = 0
+
+ call s1 (3, 4, 5)
+
+ ! All intervening code at the same depth must be executed the same
+ ! number of times.
+ if (f1count(1) /= f2count(1)) error stop 101
+ if (f1count(2) /= f2count(2)) error stop 102
+ if (f1count(3) /= f2count(3)) error stop 103
+ if (g1count(1) /= f1count(1)) error stop 104
+ if (g2count(1) /= f1count(1)) error stop 105
+ if (g1count(2) /= f1count(2)) error stop 106
+ if (g2count(2) /= f1count(2)) error stop 107
+ if (g1count(3) /= f1count(3)) error stop 108
+ if (g2count(3) /= f1count(3)) error stop 109
+
+ ! Intervening code must be executed at least as many times as the loop
+ ! that encloses it.
+ if (f1count(1) < 3) error stop 111
+ if (f1count(2) < 3 * 4) error stop 112
+
+ ! Intervening code must not be executed more times than the number
+ ! of logical iterations.
+ if (f1count(1) > 3 * 4 * 5) error stop 121
+ if (f1count(2) > 3 * 4 * 5) error stop 122
+
+ ! Check that the innermost loop body is executed exactly the number
+ ! of logical iterations expected.
+ if (f1count(3) /= 3 * 4 * 5) error stop 131
+
+ ! Check that constructors and destructors are called equal number of times.
+ if (ccount(1) /= dcount(1)) error stop 141
+ if (ccount(2) /= dcount(2)) error stop 142
+ if (ccount(3) /= dcount(3)) error stop 143
+
+contains
+
+subroutine f1 (depth, iter)
+ integer :: depth, iter
+ f1count(depth) = f1count(depth) + 1
+end subroutine
+
+subroutine f2 (depth, iter)
+ integer :: depth, iter
+ f2count(depth) = f2count(depth) + 1
+end subroutine
+
+subroutine g1 (depth, iter)
+ integer :: depth, iter
+ g1count(depth) = g1count(depth) + 1
+end subroutine
+
+subroutine g2 (depth, iter)
+ integer :: depth, iter
+ g2count(depth) = g2count(depth) + 1
+end subroutine
+
+subroutine s1 (a1, a2, a3)
+ integer :: a1, a2, a3
+ integer :: i, j, k
+
+ !$omp do collapse(3)
+ do i = 1, a1
+ call f1 (1, i)
+ block
+ type (t) :: local1
+ call init (local1, 1)
+ call g1 (local1%i, i)
+ do j = 1, a2
+ call f1 (2, j)
+ block
+ type (t) :: local2
+ call init (local2, 2)
+ call g1 (local2%i, j)
+ do k = 1, a3
+ call f1 (3, k)
+ block
+ type (t) :: local3
+ call init (local3, 3)
+ call g1 (local3%i, k)
+ call g2 (local3%i, k)
+ end block
+ call f2 (3, k)
+ end do
+ call g2 (local2%i, j)
+ end block
+ call f2 (2, j)
+ end do
+ call g2 (local1%i, i)
+ end block
+ call f2 (1, i)
+ end do
+
+end subroutine
+
+end program
new file mode 100644
@@ -0,0 +1,67 @@
+! { dg-do run }
+
+program foo
+ integer, save :: f1count(3), f2count(3)
+
+ f1count(1) = 0
+ f1count(2) = 0
+ f1count(3) = 0
+ f2count(1) = 0
+ f2count(2) = 0
+ f2count(3) = 0
+
+ call s1 (3, 4, 5)
+
+ ! All intervening code at the same depth must be executed the same
+ ! number of times.
+ if (f1count(1) /= f2count(1)) error stop 101
+ if (f1count(2) /= f2count(2)) error stop 102
+ if (f1count(3) /= f2count(3)) error stop 103
+
+ ! Intervening code must be executed at least as many times as the loop
+ ! that encloses it.
+ if (f1count(1) < 3) error stop 111
+ if (f1count(2) < 3 * 4) error stop 112
+
+ ! Intervening code must not be executed more times than the number
+ ! of logical iterations.
+ if (f1count(1) > 3 * 4 * 5) error stop 121
+ if (f1count(2) > 3 * 4 * 5) error stop 122
+
+ ! Check that the innermost loop body is executed exactly the number
+ ! of logical iterations expected.
+ if (f1count(3) /= 3 * 4 * 5) error stop 131
+
+contains
+
+subroutine f1 (depth, iter)
+ integer :: depth, iter
+ f1count(depth) = f1count(depth) + 1
+end subroutine
+
+subroutine f2 (depth, iter)
+ integer :: depth, iter
+ f2count(depth) = f2count(depth) + 1
+end subroutine
+
+subroutine s1 (a1, a2, a3)
+ integer :: a1, a2, a3
+ integer :: i, j, k
+
+ !$omp do collapse(3)
+ do i = 1, a1
+ call f1 (1, i)
+ do j = 1, a2
+ call f1 (2, j)
+ do k = 1, a3
+ call f1 (3, k)
+ call f2 (3, k)
+ end do
+ call f2 (2, j)
+ end do
+ call f2 (1, i)
+ end do
+
+end subroutine
+
+end program
new file mode 100644
@@ -0,0 +1,102 @@
+! { dg-do run }
+
+program foo
+ integer, save :: f1count(3), f2count(3), g1count(3), g2count(3)
+
+ f1count(1) = 0
+ f1count(2) = 0
+ f1count(3) = 0
+ f2count(1) = 0
+ f2count(2) = 0
+ f2count(3) = 0
+
+ g1count(1) = 0
+ g1count(2) = 0
+ g1count(3) = 0
+ g2count(1) = 0
+ g2count(2) = 0
+ g2count(3) = 0
+
+ call s1 (3, 4, 5)
+
+ ! All intervening code at the same depth must be executed the same
+ ! number of times.
+ if (f1count(1) /= f2count(1)) error stop 101
+ if (f1count(2) /= f2count(2)) error stop 102
+ if (f1count(3) /= f2count(3)) error stop 103
+ if (g1count(1) /= f1count(1)) error stop 104
+ if (g2count(1) /= f1count(1)) error stop 105
+ if (g1count(2) /= f1count(2)) error stop 106
+ if (g2count(2) /= f1count(2)) error stop 107
+ if (g1count(3) /= f1count(3)) error stop 108
+ if (g2count(3) /= f1count(3)) error stop 109
+
+ ! Intervening code must be executed at least as many times as the loop
+ ! that encloses it.
+ if (f1count(1) < 3) error stop 111
+ if (f1count(2) < 3 * 4) error stop 112
+
+ ! Intervening code must not be executed more times than the number
+ ! of logical iterations.
+ if (f1count(1) > 3 * 4 * 5) error stop 121
+ if (f1count(2) > 3 * 4 * 5) error stop 122
+
+ ! Check that the innermost loop body is executed exactly the number
+ ! of logical iterations expected.
+ if (f1count(3) /= 3 * 4 * 5) error stop 131
+
+contains
+
+subroutine f1 (depth, iter)
+ integer :: depth, iter
+ f1count(depth) = f1count(depth) + 1
+end subroutine
+
+subroutine f2 (depth, iter)
+ integer :: depth, iter
+ f2count(depth) = f2count(depth) + 1
+end subroutine
+
+subroutine g1 (depth, iter)
+ integer :: depth, iter
+ g1count(depth) = g1count(depth) + 1
+end subroutine
+
+subroutine g2 (depth, iter)
+ integer :: depth, iter
+ g2count(depth) = g2count(depth) + 1
+end subroutine
+
+subroutine s1 (a1, a2, a3)
+ integer :: a1, a2, a3
+ integer :: i, j, k
+
+ !$omp do collapse(3)
+ do i = 1, a1
+ call f1 (1, i)
+ block
+ call g1 (1, i)
+ do j = 1, a2
+ call f1 (2, j)
+ block
+ call g1 (2, j)
+ do k = 1, a3
+ call f1 (3, k)
+ block
+ call g1 (3, k)
+ call g2 (3, k)
+ end block
+ call f2 (3, k)
+ end do
+ call g2 (2, j)
+ end block
+ call f2 (2, j)
+ end do
+ call g2 (1, i)
+ end block
+ call f2 (1, i)
+ end do
+
+end subroutine
+
+end program
new file mode 100644
@@ -0,0 +1,110 @@
+! { dg-do run }
+
+! Like imperfect2.f90, but adds bindings to the blocks.
+
+program foo
+ integer, save :: f1count(3), f2count(3), g1count(3), g2count(3)
+
+ f1count(1) = 0
+ f1count(2) = 0
+ f1count(3) = 0
+ f2count(1) = 0
+ f2count(2) = 0
+ f2count(3) = 0
+
+ g1count(1) = 0
+ g1count(2) = 0
+ g1count(3) = 0
+ g2count(1) = 0
+ g2count(2) = 0
+ g2count(3) = 0
+
+ call s1 (3, 4, 5)
+
+ ! All intervening code at the same depth must be executed the same
+ ! number of times.
+ if (f1count(1) /= f2count(1)) error stop 101
+ if (f1count(2) /= f2count(2)) error stop 102
+ if (f1count(3) /= f2count(3)) error stop 103
+ if (g1count(1) /= f1count(1)) error stop 104
+ if (g2count(1) /= f1count(1)) error stop 105
+ if (g1count(2) /= f1count(2)) error stop 106
+ if (g2count(2) /= f1count(2)) error stop 107
+ if (g1count(3) /= f1count(3)) error stop 108
+ if (g2count(3) /= f1count(3)) error stop 109
+
+ ! Intervening code must be executed at least as many times as the loop
+ ! that encloses it.
+ if (f1count(1) < 3) error stop 111
+ if (f1count(2) < 3 * 4) error stop 112
+
+ ! Intervening code must not be executed more times than the number
+ ! of logical iterations.
+ if (f1count(1) > 3 * 4 * 5) error stop 121
+ if (f1count(2) > 3 * 4 * 5) error stop 122
+
+ ! Check that the innermost loop body is executed exactly the number
+ ! of logical iterations expected.
+ if (f1count(3) /= 3 * 4 * 5) error stop 131
+
+contains
+
+subroutine f1 (depth, iter)
+ integer :: depth, iter
+ f1count(depth) = f1count(depth) + 1
+end subroutine
+
+subroutine f2 (depth, iter)
+ integer :: depth, iter
+ f2count(depth) = f2count(depth) + 1
+end subroutine
+
+subroutine g1 (depth, iter)
+ integer :: depth, iter
+ g1count(depth) = g1count(depth) + 1
+end subroutine
+
+subroutine g2 (depth, iter)
+ integer :: depth, iter
+ g2count(depth) = g2count(depth) + 1
+end subroutine
+
+subroutine s1 (a1, a2, a3)
+ integer :: a1, a2, a3
+ integer :: i, j, k
+
+ !$omp do collapse(3)
+ do i = 1, a1
+ call f1 (1, i)
+ block
+ integer :: local1
+ local1 = 1
+ call g1 (local1, i)
+ do j = 1, a2
+ call f1 (2, j)
+ block
+ integer :: local2
+ local2 = 2
+ call g1 (local2, j)
+ do k = 1, a3
+ call f1 (3, k)
+ block
+ integer :: local3
+ local3 = 3
+ call g1 (local3, k)
+ call g2 (local3, k)
+ end block
+ call f2 (3, k)
+ end do
+ call g2 (local2, j)
+ end block
+ call f2 (2, j)
+ end do
+ call g2 (local1, i)
+ end block
+ call f2 (1, i)
+ end do
+
+end subroutine
+
+end program
new file mode 100644
@@ -0,0 +1,121 @@
+! { dg-do run }
+
+! Like imperfect2.f90, but includes blocks that are themselves wholly
+! intervening code and not containers for nested loops.
+
+program foo
+ integer, save :: f1count(3), f2count(3), g1count(3), g2count(3)
+
+ f1count(1) = 0
+ f1count(2) = 0
+ f1count(3) = 0
+ f2count(1) = 0
+ f2count(2) = 0
+ f2count(3) = 0
+
+ g1count(1) = 0
+ g1count(2) = 0
+ g1count(3) = 0
+ g2count(1) = 0
+ g2count(2) = 0
+ g2count(3) = 0
+
+ call s1 (3, 4, 5)
+
+ ! All intervening code at the same depth must be executed the same
+ ! number of times.
+ if (f1count(1) /= f2count(1)) error stop 101
+ if (f1count(2) /= f2count(2)) error stop 102
+ if (f1count(3) /= f2count(3)) error stop 103
+ if (g1count(1) /= f1count(1)) error stop 104
+ if (g2count(1) /= f1count(1)) error stop 105
+ if (g1count(2) /= f1count(2)) error stop 106
+ if (g2count(2) /= f1count(2)) error stop 107
+ if (g1count(3) /= f1count(3)) error stop 108
+ if (g2count(3) /= f1count(3)) error stop 109
+
+ ! Intervening code must be executed at least as many times as the loop
+ ! that encloses it.
+ if (f1count(1) < 3) error stop 111
+ if (f1count(2) < 3 * 4) error stop 112
+
+ ! Intervening code must not be executed more times than the number
+ ! of logical iterations.
+ if (f1count(1) > 3 * 4 * 5) error stop 121
+ if (f1count(2) > 3 * 4 * 5) error stop 122
+
+ ! Check that the innermost loop body is executed exactly the number
+ ! of logical iterations expected.
+ if (f1count(3) /= 3 * 4 * 5) error stop 131
+
+contains
+
+subroutine f1 (depth, iter)
+ integer :: depth, iter
+ f1count(depth) = f1count(depth) + 1
+end subroutine
+
+subroutine f2 (depth, iter)
+ integer :: depth, iter
+ f2count(depth) = f2count(depth) + 1
+end subroutine
+
+subroutine g1 (depth, iter)
+ integer :: depth, iter
+ g1count(depth) = g1count(depth) + 1
+end subroutine
+
+subroutine g2 (depth, iter)
+ integer :: depth, iter
+ g2count(depth) = g2count(depth) + 1
+end subroutine
+
+subroutine s1 (a1, a2, a3)
+ integer :: a1, a2, a3
+ integer :: i, j, k
+
+ !$omp do collapse(3)
+ do i = 1, a1
+ block
+ call f1 (1, i)
+ end block
+ block
+ block
+ call g1 (1, i)
+ end block
+ do j = 1, a2
+ block
+ call f1 (2, j)
+ end block
+ block
+ block
+ call g1 (2, j)
+ end block
+ do k = 1, a3
+ call f1 (3, k)
+ block
+ call g1 (3, k)
+ call g2 (3, k)
+ end block
+ call f2 (3, k)
+ end do
+ block
+ call g2 (2, j)
+ end block
+ end block
+ block
+ call f2 (2, j)
+ end block
+ end do
+ block
+ call g2 (1, i)
+ end block
+ end block
+ block
+ call f2 (1, i)
+ end block
+ end do
+
+end subroutine
+
+end program
new file mode 100644
@@ -0,0 +1,72 @@
+! { dg-do run }
+
+! Like imperfect1.f90, but enables offloading.
+
+program foo
+ integer, save :: f1count(3), f2count(3)
+ !$omp declare target enter (f1count, f2count)
+
+ f1count(1) = 0
+ f1count(2) = 0
+ f1count(3) = 0
+ f2count(1) = 0
+ f2count(2) = 0
+ f2count(3) = 0
+
+ call s1 (3, 4, 5)
+
+ ! All intervening code at the same depth must be executed the same
+ ! number of times.
+ if (f1count(1) /= f2count(1)) error stop 101
+ if (f1count(2) /= f2count(2)) error stop 102
+ if (f1count(3) /= f2count(3)) error stop 103
+
+ ! Intervening code must be executed at least as many times as the loop
+ ! that encloses it.
+ if (f1count(1) < 3) error stop 111
+ if (f1count(2) < 3 * 4) error stop 112
+
+ ! Intervening code must not be executed more times than the number
+ ! of logical iterations.
+ if (f1count(1) > 3 * 4 * 5) error stop 121
+ if (f1count(2) > 3 * 4 * 5) error stop 122
+
+ ! Check that the innermost loop body is executed exactly the number
+ ! of logical iterations expected.
+ if (f1count(3) /= 3 * 4 * 5) error stop 131
+
+contains
+
+subroutine f1 (depth, iter)
+ integer :: depth, iter
+ !$omp atomic
+ f1count(depth) = f1count(depth) + 1
+end subroutine
+
+subroutine f2 (depth, iter)
+ integer :: depth, iter
+ !$omp atomic
+ f2count(depth) = f2count(depth) + 1
+end subroutine
+
+subroutine s1 (a1, a2, a3)
+ integer :: a1, a2, a3
+ integer :: i, j, k
+
+ !$omp target parallel do collapse(3) map(always, tofrom:f1count, f2count)
+ do i = 1, a1
+ call f1 (1, i)
+ do j = 1, a2
+ call f1 (2, j)
+ do k = 1, a3
+ call f1 (3, k)
+ call f2 (3, k)
+ end do
+ call f2 (2, j)
+ end do
+ call f2 (1, i)
+ end do
+
+end subroutine
+
+end program
new file mode 100644
@@ -0,0 +1,110 @@
+! { dg-do run }
+
+! Like imperfect2.f90, but enables offloading.
+
+program foo
+ integer, save :: f1count(3), f2count(3), g1count(3), g2count(3)
+ !$omp declare target enter (f1count, f2count)
+ !$omp declare target enter (g1count, g2count)
+
+ f1count(1) = 0
+ f1count(2) = 0
+ f1count(3) = 0
+ f2count(1) = 0
+ f2count(2) = 0
+ f2count(3) = 0
+
+ g1count(1) = 0
+ g1count(2) = 0
+ g1count(3) = 0
+ g2count(1) = 0
+ g2count(2) = 0
+ g2count(3) = 0
+
+ call s1 (3, 4, 5)
+
+ ! All intervening code at the same depth must be executed the same
+ ! number of times.
+ if (f1count(1) /= f2count(1)) error stop 101
+ if (f1count(2) /= f2count(2)) error stop 102
+ if (f1count(3) /= f2count(3)) error stop 103
+ if (g1count(1) /= f1count(1)) error stop 104
+ if (g2count(1) /= f1count(1)) error stop 105
+ if (g1count(2) /= f1count(2)) error stop 106
+ if (g2count(2) /= f1count(2)) error stop 107
+ if (g1count(3) /= f1count(3)) error stop 108
+ if (g2count(3) /= f1count(3)) error stop 109
+
+ ! Intervening code must be executed at least as many times as the loop
+ ! that encloses it.
+ if (f1count(1) < 3) error stop 111
+ if (f1count(2) < 3 * 4) error stop 112
+
+ ! Intervening code must not be executed more times than the number
+ ! of logical iterations.
+ if (f1count(1) > 3 * 4 * 5) error stop 121
+ if (f1count(2) > 3 * 4 * 5) error stop 122
+
+ ! Check that the innermost loop body is executed exactly the number
+ ! of logical iterations expected.
+ if (f1count(3) /= 3 * 4 * 5) error stop 131
+
+contains
+
+subroutine f1 (depth, iter)
+ integer :: depth, iter
+ !$omp atomic
+ f1count(depth) = f1count(depth) + 1
+end subroutine
+
+subroutine f2 (depth, iter)
+ integer :: depth, iter
+ !$omp atomic
+ f2count(depth) = f2count(depth) + 1
+end subroutine
+
+subroutine g1 (depth, iter)
+ integer :: depth, iter
+ !$omp atomic
+ g1count(depth) = g1count(depth) + 1
+end subroutine
+
+subroutine g2 (depth, iter)
+ integer :: depth, iter
+ !$omp atomic
+ g2count(depth) = g2count(depth) + 1
+end subroutine
+
+subroutine s1 (a1, a2, a3)
+ integer :: a1, a2, a3
+ integer :: i, j, k
+
+ !$omp target parallel do collapse(3) map(always, tofrom:f1count, f2count, g1count, g2count)
+ do i = 1, a1
+ call f1 (1, i)
+ block
+ call g1 (1, i)
+ do j = 1, a2
+ call f1 (2, j)
+ block
+ call g1 (2, j)
+ do k = 1, a3
+ call f1 (3, k)
+ block
+ call g1 (3, k)
+ call g2 (3, k)
+ end block
+ call f2 (3, k)
+ end do
+ call g2 (2, j)
+ end block
+ call f2 (2, j)
+ end do
+ call g2 (1, i)
+ end block
+ call f2 (1, i)
+ end do
+
+end subroutine
+
+end program
new file mode 100644
@@ -0,0 +1,116 @@
+! { dg-do run }
+
+! Like imperfect3.f90, but enables offloading.
+
+program foo
+ integer, save :: f1count(3), f2count(3), g1count(3), g2count(3)
+ !$omp declare target enter (f1count, f2count)
+ !$omp declare target enter (g1count, g2count)
+
+ f1count(1) = 0
+ f1count(2) = 0
+ f1count(3) = 0
+ f2count(1) = 0
+ f2count(2) = 0
+ f2count(3) = 0
+
+ g1count(1) = 0
+ g1count(2) = 0
+ g1count(3) = 0
+ g2count(1) = 0
+ g2count(2) = 0
+ g2count(3) = 0
+
+ call s1 (3, 4, 5)
+
+ ! All intervening code at the same depth must be executed the same
+ ! number of times.
+ if (f1count(1) /= f2count(1)) error stop 101
+ if (f1count(2) /= f2count(2)) error stop 102
+ if (f1count(3) /= f2count(3)) error stop 103
+ if (g1count(1) /= f1count(1)) error stop 104
+ if (g2count(1) /= f1count(1)) error stop 105
+ if (g1count(2) /= f1count(2)) error stop 106
+ if (g2count(2) /= f1count(2)) error stop 107
+ if (g1count(3) /= f1count(3)) error stop 108
+ if (g2count(3) /= f1count(3)) error stop 109
+
+ ! Intervening code must be executed at least as many times as the loop
+ ! that encloses it.
+ if (f1count(1) < 3) error stop 111
+ if (f1count(2) < 3 * 4) error stop 112
+
+ ! Intervening code must not be executed more times than the number
+ ! of logical iterations.
+ if (f1count(1) > 3 * 4 * 5) error stop 121
+ if (f1count(2) > 3 * 4 * 5) error stop 122
+
+ ! Check that the innermost loop body is executed exactly the number
+ ! of logical iterations expected.
+ if (f1count(3) /= 3 * 4 * 5) error stop 131
+
+contains
+
+subroutine f1 (depth, iter)
+ integer :: depth, iter
+ !$omp atomic
+ f1count(depth) = f1count(depth) + 1
+end subroutine
+
+subroutine f2 (depth, iter)
+ integer :: depth, iter
+ !$omp atomic
+ f2count(depth) = f2count(depth) + 1
+end subroutine
+
+subroutine g1 (depth, iter)
+ integer :: depth, iter
+ !$omp atomic
+ g1count(depth) = g1count(depth) + 1
+end subroutine
+
+subroutine g2 (depth, iter)
+ integer :: depth, iter
+ !$omp atomic
+ g2count(depth) = g2count(depth) + 1
+end subroutine
+
+subroutine s1 (a1, a2, a3)
+ integer :: a1, a2, a3
+ integer :: i, j, k
+
+ !$omp target parallel do collapse(3) map(always, tofrom:f1count, f2count, g1count, g2count)
+ do i = 1, a1
+ call f1 (1, i)
+ block
+ integer :: local1
+ local1 = 1
+ call g1 (local1, i)
+ do j = 1, a2
+ call f1 (2, j)
+ block
+ integer :: local2
+ local2 = 2
+ call g1 (local2, j)
+ do k = 1, a3
+ call f1 (3, k)
+ block
+ integer :: local3
+ local3 = 3
+ call g1 (local3, k)
+ call g2 (local3, k)
+ end block
+ call f2 (3, k)
+ end do
+ call g2 (local2, j)
+ end block
+ call f2 (2, j)
+ end do
+ call g2 (local1, i)
+ end block
+ call f2 (1, i)
+ end do
+
+end subroutine
+
+end program
new file mode 100644
@@ -0,0 +1,126 @@
+! { dg-do run }
+
+! Like imperfect4.f90, but enables offloading.
+
+program foo
+ integer, save :: f1count(3), f2count(3), g1count(3), g2count(3)
+ !$omp declare target enter (f1count, f2count)
+ !$omp declare target enter (g1count, g2count)
+
+ f1count(1) = 0
+ f1count(2) = 0
+ f1count(3) = 0
+ f2count(1) = 0
+ f2count(2) = 0
+ f2count(3) = 0
+
+ g1count(1) = 0
+ g1count(2) = 0
+ g1count(3) = 0
+ g2count(1) = 0
+ g2count(2) = 0
+ g2count(3) = 0
+
+ call s1 (3, 4, 5)
+
+ ! All intervening code at the same depth must be executed the same
+ ! number of times.
+ if (f1count(1) /= f2count(1)) error stop 101
+ if (f1count(2) /= f2count(2)) error stop 102
+ if (f1count(3) /= f2count(3)) error stop 103
+ if (g1count(1) /= f1count(1)) error stop 104
+ if (g2count(1) /= f1count(1)) error stop 105
+ if (g1count(2) /= f1count(2)) error stop 106
+ if (g2count(2) /= f1count(2)) error stop 107
+ if (g1count(3) /= f1count(3)) error stop 108
+ if (g2count(3) /= f1count(3)) error stop 109
+
+ ! Intervening code must be executed at least as many times as the loop
+ ! that encloses it.
+ if (f1count(1) < 3) error stop 111
+ if (f1count(2) < 3 * 4) error stop 112
+
+ ! Intervening code must not be executed more times than the number
+ ! of logical iterations.
+ if (f1count(1) > 3 * 4 * 5) error stop 121
+ if (f1count(2) > 3 * 4 * 5) error stop 122
+
+ ! Check that the innermost loop body is executed exactly the number
+ ! of logical iterations expected.
+ if (f1count(3) /= 3 * 4 * 5) error stop 131
+
+contains
+
+subroutine f1 (depth, iter)
+ integer :: depth, iter
+ !$omp atomic
+ f1count(depth) = f1count(depth) + 1
+end subroutine
+
+subroutine f2 (depth, iter)
+ integer :: depth, iter
+ !$omp atomic
+ f2count(depth) = f2count(depth) + 1
+end subroutine
+
+subroutine g1 (depth, iter)
+ integer :: depth, iter
+ !$omp atomic
+ g1count(depth) = g1count(depth) + 1
+end subroutine
+
+subroutine g2 (depth, iter)
+ integer :: depth, iter
+ !$omp atomic
+ g2count(depth) = g2count(depth) + 1
+end subroutine
+
+subroutine s1 (a1, a2, a3)
+ integer :: a1, a2, a3
+ integer :: i, j, k
+
+ !$omp target parallel do collapse(3) map(always, tofrom:f1count, f2count, g1count, g2count)
+ do i = 1, a1
+ block
+ call f1 (1, i)
+ end block
+ block
+ block
+ call g1 (1, i)
+ end block
+ do j = 1, a2
+ block
+ call f1 (2, j)
+ end block
+ block
+ block
+ call g1 (2, j)
+ end block
+ do k = 1, a3
+ call f1 (3, k)
+ block
+ call g1 (3, k)
+ call g2 (3, k)
+ end block
+ call f2 (3, k)
+ end do
+ block
+ call g2 (2, j)
+ end block
+ end block
+ block
+ call f2 (2, j)
+ end block
+ end do
+ block
+ call g2 (1, i)
+ end block
+ end block
+ block
+ call f2 (1, i)
+ end block
+ end do
+
+end subroutine
+
+end program