From: Sandra Loosemore <sandra@codesourcery.com>
To: <gcc-patches@gcc.gnu.org>
Cc: <jakub@redhat.com>, <tobias@codesourcery.com>
Subject: [COMMITTED V3 5/6] OpenMP: Fortran support for imperfectly-nested loops
Date: Fri, 25 Aug 2023 13:47:13 -0600 [thread overview]
Message-ID: <20230825194714.627157-6-sandra@codesourcery.com> (raw)
In-Reply-To: <20230825194714.627157-1-sandra@codesourcery.com>
OpenMP 5.0 removed the restriction that multiple collapsed loops must
be perfectly nested, allowing "intervening code" (including nested
BLOCKs) before or after each nested loop. In GCC this code is moved
into the inner loop body by the respective front ends.
In the Fortran front end, most of the semantic processing happens during
the translation phase, so the parse phase just collects the intervening
statements, checks them for errors, and splices them around the loop body.
gcc/fortran/ChangeLog
* gfortran.h (struct gfc_namespace): Add omp_structured_block bit.
* openmp.cc: Include omp-api.h.
(resolve_omp_clauses): Consolidate inscan reduction clause conflict
checking here.
(find_nested_loop_in_chain): New.
(find_nested_loop_in_block): New.
(gfc_resolve_omp_do_blocks): Set omp_current_do_collapse properly.
Handle imperfectly-nested loops when looking for nested omp scan.
Refactor to move inscan reduction clause conflict checking to
resolve_omp_clauses.
(gfc_resolve_do_iterator): Handle imperfectly-nested loops.
(struct icode_error_state): New.
(icode_code_error_callback): New.
(icode_expr_error_callback): New.
(diagnose_intervening_code_errors_1): New.
(diagnose_intervening_code_errors): New.
(make_structured_block): New.
(restructure_intervening_code): New.
(is_outer_iteration_variable): Do not assume loops are perfectly
nested.
(check_nested_loop_in_chain): New.
(check_nested_loop_in_block_state): New.
(check_nested_loop_in_block_symbol): New.
(check_nested_loop_in_block): New.
(expr_uses_intervening_var): New.
(is_intervening_var): New.
(expr_is_invariant): Do not assume loops are perfectly nested.
(resolve_omp_do): Handle imperfectly-nested loops.
* trans-stmt.cc (gfc_trans_block_construct): Generate
OMP_STRUCTURED_BLOCK if magic bit is set on block namespace.
gcc/testsuite/ChangeLog
* gfortran.dg/gomp/collapse1.f90: Adjust expected errors.
* gfortran.dg/gomp/collapse2.f90: Likewise.
* gfortran.dg/gomp/imperfect-gotos.f90: New.
* gfortran.dg/gomp/imperfect-invalid-scope.f90: New.
* gfortran.dg/gomp/imperfect1.f90: New.
* gfortran.dg/gomp/imperfect2.f90: New.
* gfortran.dg/gomp/imperfect3.f90: New.
* gfortran.dg/gomp/imperfect4.f90: New.
* gfortran.dg/gomp/imperfect5.f90: New.
libgomp/ChangeLog
* testsuite/libgomp.fortran/imperfect-destructor.f90: New.
* testsuite/libgomp.fortran/imperfect1.f90: New.
* testsuite/libgomp.fortran/imperfect2.f90: New.
* testsuite/libgomp.fortran/imperfect3.f90: New.
* testsuite/libgomp.fortran/imperfect4.f90: New.
* testsuite/libgomp.fortran/target-imperfect1.f90: New.
* testsuite/libgomp.fortran/target-imperfect2.f90: New.
* testsuite/libgomp.fortran/target-imperfect3.f90: New.
* testsuite/libgomp.fortran/target-imperfect4.f90: New.
---
gcc/fortran/gfortran.h | 3 +
gcc/fortran/openmp.cc | 763 +++++++++++++++---
gcc/fortran/trans-stmt.cc | 7 +-
gcc/testsuite/gfortran.dg/gomp/collapse1.f90 | 6 +-
gcc/testsuite/gfortran.dg/gomp/collapse2.f90 | 10 +-
.../gfortran.dg/gomp/imperfect-gotos.f90 | 69 ++
.../gomp/imperfect-invalid-scope.f90 | 81 ++
gcc/testsuite/gfortran.dg/gomp/imperfect1.f90 | 39 +
gcc/testsuite/gfortran.dg/gomp/imperfect2.f90 | 56 ++
gcc/testsuite/gfortran.dg/gomp/imperfect3.f90 | 45 ++
gcc/testsuite/gfortran.dg/gomp/imperfect4.f90 | 36 +
gcc/testsuite/gfortran.dg/gomp/imperfect5.f90 | 85 ++
.../libgomp.fortran/imperfect-destructor.f90 | 142 ++++
.../testsuite/libgomp.fortran/imperfect1.f90 | 67 ++
.../testsuite/libgomp.fortran/imperfect2.f90 | 102 +++
.../testsuite/libgomp.fortran/imperfect3.f90 | 110 +++
.../testsuite/libgomp.fortran/imperfect4.f90 | 121 +++
.../libgomp.fortran/target-imperfect1.f90 | 72 ++
.../libgomp.fortran/target-imperfect2.f90 | 110 +++
.../libgomp.fortran/target-imperfect3.f90 | 116 +++
.../libgomp.fortran/target-imperfect4.f90 | 126 +++
21 files changed, 2058 insertions(+), 108 deletions(-)
create mode 100644 gcc/testsuite/gfortran.dg/gomp/imperfect-gotos.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/imperfect-invalid-scope.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/imperfect1.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/imperfect2.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/imperfect3.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/imperfect4.f90
create mode 100644 gcc/testsuite/gfortran.dg/gomp/imperfect5.f90
create mode 100644 libgomp/testsuite/libgomp.fortran/imperfect-destructor.f90
create mode 100644 libgomp/testsuite/libgomp.fortran/imperfect1.f90
create mode 100644 libgomp/testsuite/libgomp.fortran/imperfect2.f90
create mode 100644 libgomp/testsuite/libgomp.fortran/imperfect3.f90
create mode 100644 libgomp/testsuite/libgomp.fortran/imperfect4.f90
create mode 100644 libgomp/testsuite/libgomp.fortran/target-imperfect1.f90
create mode 100644 libgomp/testsuite/libgomp.fortran/target-imperfect2.f90
create mode 100644 libgomp/testsuite/libgomp.fortran/target-imperfect3.f90
create mode 100644 libgomp/testsuite/libgomp.fortran/target-imperfect4.f90
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index cce9688ee6a..413726d943c 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -2237,6 +2237,9 @@ typedef struct gfc_namespace
/* OpenMP requires. */
unsigned omp_requires:6;
unsigned omp_target_seen:1;
+
+ /* Set to 1 if this is an implicit OMP structured block. */
+ unsigned omp_structured_block:1;
}
gfc_namespace;
diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc
index 2ffbf6f5ef9..dc0c8013c3d 100644
--- a/gcc/fortran/openmp.cc
+++ b/gcc/fortran/openmp.cc
@@ -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 *);
@@ -7616,15 +7617,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
@@ -9573,68 +9583,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);
@@ -9764,12 +9820,11 @@ 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. */
@@ -9809,20 +9864,464 @@ 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 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;
}
@@ -9833,14 +10332,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;
}
@@ -9911,12 +10411,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;
- 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)
{
@@ -10019,12 +10521,12 @@ resolve_omp_do (gfc_code *code)
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
@@ -10032,29 +10534,36 @@ resolve_omp_do (gfc_code *code)
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
@@ -10073,13 +10582,20 @@ 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 (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,
@@ -10087,7 +10603,15 @@ 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 (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,
@@ -10095,48 +10619,89 @@ 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 (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);
}
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index 93f36bfb955..50b71e67234 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -2334,6 +2334,7 @@ gfc_trans_block_construct (gfc_code* code)
tree exit_label;
stmtblock_t body;
gfc_association_list *ass;
+ tree translated_body;
ns = code->ext.block.ns;
gcc_assert (ns);
@@ -2352,7 +2353,11 @@ gfc_trans_block_construct (gfc_code* code)
finish_oacc_declare (ns, sym, true);
- gfc_add_expr_to_block (&body, gfc_trans_code (ns->code));
+ translated_body = gfc_trans_code (ns->code);
+ if (ns->omp_structured_block)
+ translated_body = build1 (OMP_STRUCTURED_BLOCK, void_type_node,
+ translated_body);
+ gfc_add_expr_to_block (&body, translated_body);
gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label));
/* Finish everything. */
diff --git a/gcc/testsuite/gfortran.dg/gomp/collapse1.f90 b/gcc/testsuite/gfortran.dg/gomp/collapse1.f90
index 77b2bdd7fcb..613f06f6ea9 100644
--- a/gcc/testsuite/gfortran.dg/gomp/collapse1.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/collapse1.f90
@@ -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)
diff --git a/gcc/testsuite/gfortran.dg/gomp/collapse2.f90 b/gcc/testsuite/gfortran.dg/gomp/collapse2.f90
index 1ab934e3d0d..9af3b656829 100644
--- a/gcc/testsuite/gfortran.dg/gomp/collapse2.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/collapse2.f90
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/gomp/imperfect-gotos.f90 b/gcc/testsuite/gfortran.dg/gomp/imperfect-gotos.f90
new file mode 100644
index 00000000000..e184ffe631e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/imperfect-gotos.f90
@@ -0,0 +1,69 @@
+! This test case is expected to fail due to errors.
+
+! These jumps are all OK since they are to/from the same structured block.
+subroutine f1 ()
+ integer :: i, j
+ !$omp do collapse(2)
+ do i = 1, 64
+ go to 10
+10 continue
+ do j = 1, 64
+ go to 11
+11 continue
+ end do
+ go to 12
+12 continue
+ end do
+end subroutine
+
+! Jump around loop body to/from different structured blocks of intervening
+! code.
+subroutine f2 ()
+ integer :: i, j
+ !$omp do collapse(2)
+ do i = 1, 64
+ go to 20
+20 continue
+ if (i > 16) go to 22 ! { dg-error "invalid branch to/from OpenMP structured block" }
+ do j = 1, 64
+ go to 21
+21 continue
+ end do
+ go to 22
+22 continue
+ end do
+end subroutine
+
+! Jump into loop body from intervening code.
+subroutine f3 ()
+ integer :: i, j
+ !$omp do collapse(2)
+ do i = 1, 64
+ go to 30
+30 continue
+ if (i > 16) go to 31 ! { dg-error "invalid branch to/from OpenMP structured block" }
+ ! { dg-warning "Legacy Extension:" "" { target *-*-* } .-1 }
+ do j = 1, 64
+ go to 31
+31 continue ! { dg-warning "Legacy Extension:" }
+ end do
+ go to 32
+32 continue
+ end do
+end subroutine
+
+! Jump out of loop body to intervening code.
+subroutine f4 ()
+ integer :: i, j
+ !$omp do collapse(2)
+ do i = 1, 64
+ go to 40
+40 continue
+ do j = 1, 64
+ if (i > 16) go to 41 ! { dg-error "invalid branch to/from OpenMP structured block" }
+ end do
+41 continue
+ go to 42
+42 continue
+ end do
+end subroutine
diff --git a/gcc/testsuite/gfortran.dg/gomp/imperfect-invalid-scope.f90 b/gcc/testsuite/gfortran.dg/gomp/imperfect-invalid-scope.f90
new file mode 100644
index 00000000000..7cc60944131
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/imperfect-invalid-scope.f90
@@ -0,0 +1,81 @@
+! Test that various errors involving references to variables bound
+! in intervening code in the DO loop control expressions are diagnosed.
+
+subroutine foo (x, y)
+ integer :: x, y
+end subroutine
+
+subroutine f1 ()
+ integer :: i, j
+
+ !$omp do collapse (2)
+ do i = 1, 64
+ block
+ integer :: v
+ v = (i + 4) * 2
+ do j = v, 64 ! { dg-error "loop start expression at .1. uses variable bound in intervening code" }
+ call foo (i, j)
+ end do
+ end block
+ end do
+end subroutine
+
+subroutine f2 ()
+ integer :: i, j
+
+ !$omp do collapse (2)
+ do i = 1, 64
+ block
+ integer :: v
+ v = (i + 4) * 2
+ do j = 1, v ! { dg-error "loop end expression at .1. uses variable bound in intervening code" }
+ call foo (i, j)
+ end do
+ end block
+ end do
+end subroutine
+
+subroutine f3 ()
+ integer :: i, j
+
+ !$omp do collapse (2)
+ do i = 1, 64
+ block
+ integer :: v
+ v = (i + 4) * 2
+ do j = 1, 64, v ! { dg-error "loop increment expression at .1. uses variable bound in intervening code" }
+ call foo (i, j)
+ end do
+ end block
+ end do
+end subroutine
+
+subroutine f4 ()
+ integer :: i
+
+ !$omp do collapse (2)
+ do i = 1, 64
+ block
+ integer :: j
+ do j = 1, 64 ! { dg-error "iteration variable at .1. is bound in intervening code" }
+ call foo (i, j)
+ end do
+ end block
+ end do
+end subroutine
+
+subroutine f5 ()
+ integer :: i
+
+ !$omp do collapse (2)
+ do i = 1, 64
+ block
+ integer :: j
+ integer :: v
+ v = (i + 4) * 2
+ do j = v, 64 ! { dg-error "iteration variable at .1. is bound in intervening code" }
+ call foo (i, j)
+ end do
+ end block
+ end do
+end subroutine
diff --git a/gcc/testsuite/gfortran.dg/gomp/imperfect1.f90 b/gcc/testsuite/gfortran.dg/gomp/imperfect1.f90
new file mode 100644
index 00000000000..4e750d9ad05
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/imperfect1.f90
@@ -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 "OpenMP 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
diff --git a/gcc/testsuite/gfortran.dg/gomp/imperfect2.f90 b/gcc/testsuite/gfortran.dg/gomp/imperfect2.f90
new file mode 100644
index 00000000000..d02191050d9
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/imperfect2.f90
@@ -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 "OpenMP 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 "OpenMP API call in intervening code" }
+ end do
+ call f2 (1, i)
+ end do
+end subroutine
+
+end program
diff --git a/gcc/testsuite/gfortran.dg/gomp/imperfect3.f90 b/gcc/testsuite/gfortran.dg/gomp/imperfect3.f90
new file mode 100644
index 00000000000..aa26a490929
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/imperfect3.f90
@@ -0,0 +1,45 @@
+! 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
+
+ ! This loop without intervening code ought to be OK.
+ !$omp do ordered(3)
+ do i = 1, a1
+ do j = 1, a2
+ do k = 1, a3
+ call f1 (3, k)
+ call f2 (3, k)
+ !$omp ordered doacross(source:omp_cur_iteration)
+ !$omp ordered doacross(sink: i - 2, j + 2, k - 1)
+ end do
+ end do
+ end do
+
+ ! Adding intervening code should make it error.
+ !$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)
+ !$omp ordered doacross(source:omp_cur_iteration)
+ !$omp ordered doacross(sink: i - 2, j + 2, k - 1)
+ end do
+ call f2 (2, j)
+ end do
+ call f2 (1, i)
+ end do
+
+end subroutine
diff --git a/gcc/testsuite/gfortran.dg/gomp/imperfect4.f90 b/gcc/testsuite/gfortran.dg/gomp/imperfect4.f90
new file mode 100644
index 00000000000..b7ccd8b6c53
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/imperfect4.f90
@@ -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
diff --git a/gcc/testsuite/gfortran.dg/gomp/imperfect5.f90 b/gcc/testsuite/gfortran.dg/gomp/imperfect5.f90
new file mode 100644
index 00000000000..d7107356329
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/imperfect5.f90
@@ -0,0 +1,85 @@
+! This test case is expected to fail due to errors.
+
+module mm
+
+implicit none
+integer, parameter :: N = 30
+integer, parameter :: M = 3
+
+integer :: a(M,N), b(M,N), c(M,N)
+
+contains
+
+subroutine dostuff (index, flag)
+ integer :: index, flag
+end subroutine
+
+! These functions should compile without error.
+subroutine good1 ()
+ integer :: i, j, x, shift
+
+ x = 0
+ !$omp parallel do simd collapse(2) reduction(inscan,+: x) private(shift)
+ do i = 1, N
+ do j = 1, M
+ x = x + a(j,i)
+ x = x + b(j,i)
+ !$omp scan inclusive(x)
+ shift = i + 29*j
+ c(j,i) = x + shift;
+ end do
+ end do
+end subroutine
+
+subroutine good2 ()
+ integer :: i, j, x, shift
+
+ x = 0
+ !$omp parallel do simd collapse(2) reduction(inscan,+: x) private(shift)
+ do i = 1, N
+ do j = 1, M
+ shift = i + 29*j
+ c(j,i) = x + shift;
+ !$omp scan exclusive(x)
+ x = x + a(j,i)
+ x = x + b(j,i)
+ end do
+ end do
+end subroutine
+
+! Adding intervening code should trigger an error.
+subroutine bad1 ()
+ integer :: i, j, x, shift
+
+ x = 0
+ !$omp parallel do simd collapse(2) reduction(inscan,+: x) private(shift) ! { dg-error "inner loops must be perfectly nested" }
+ do i = 1, N
+ call dostuff (i, 0)
+ do j = 1, M
+ x = x + a(j,i)
+ x = x + b(j,i)
+ !$omp scan inclusive(x)
+ shift = i + 29*j
+ c(j,i) = x + shift;
+ end do
+ end do
+end subroutine
+
+subroutine bad2 ()
+ integer :: i, j, x, shift
+
+ x = 0
+ !$omp parallel do simd collapse(2) reduction(inscan,+: x) private(shift) ! { dg-error "inner loops must be perfectly nested" }
+ do i = 1, N
+ do j = 1, M
+ shift = i + 29*j
+ c(j,i) = x + shift;
+ !$omp scan exclusive(x)
+ x = x + a(j,i)
+ x = x + b(j,i)
+ end do
+ call dostuff (i, 1)
+ end do
+end subroutine
+
+end module
\ No newline at end of file
diff --git a/libgomp/testsuite/libgomp.fortran/imperfect-destructor.f90 b/libgomp/testsuite/libgomp.fortran/imperfect-destructor.f90
new file mode 100644
index 00000000000..664d27fe968
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/imperfect-destructor.f90
@@ -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
diff --git a/libgomp/testsuite/libgomp.fortran/imperfect1.f90 b/libgomp/testsuite/libgomp.fortran/imperfect1.f90
new file mode 100644
index 00000000000..8c483c2a4e5
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/imperfect1.f90
@@ -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
diff --git a/libgomp/testsuite/libgomp.fortran/imperfect2.f90 b/libgomp/testsuite/libgomp.fortran/imperfect2.f90
new file mode 100644
index 00000000000..e42cb08031b
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/imperfect2.f90
@@ -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
diff --git a/libgomp/testsuite/libgomp.fortran/imperfect3.f90 b/libgomp/testsuite/libgomp.fortran/imperfect3.f90
new file mode 100644
index 00000000000..da094612332
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/imperfect3.f90
@@ -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
diff --git a/libgomp/testsuite/libgomp.fortran/imperfect4.f90 b/libgomp/testsuite/libgomp.fortran/imperfect4.f90
new file mode 100644
index 00000000000..1679c8c5b92
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/imperfect4.f90
@@ -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
diff --git a/libgomp/testsuite/libgomp.fortran/target-imperfect1.f90 b/libgomp/testsuite/libgomp.fortran/target-imperfect1.f90
new file mode 100644
index 00000000000..608eee7e424
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/target-imperfect1.f90
@@ -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
diff --git a/libgomp/testsuite/libgomp.fortran/target-imperfect2.f90 b/libgomp/testsuite/libgomp.fortran/target-imperfect2.f90
new file mode 100644
index 00000000000..982661c278a
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/target-imperfect2.f90
@@ -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
diff --git a/libgomp/testsuite/libgomp.fortran/target-imperfect3.f90 b/libgomp/testsuite/libgomp.fortran/target-imperfect3.f90
new file mode 100644
index 00000000000..6f4f92d6f3f
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/target-imperfect3.f90
@@ -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
diff --git a/libgomp/testsuite/libgomp.fortran/target-imperfect4.f90 b/libgomp/testsuite/libgomp.fortran/target-imperfect4.f90
new file mode 100644
index 00000000000..59ec0e92b05
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/target-imperfect4.f90
@@ -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
--
2.31.1
next prev parent reply other threads:[~2023-08-25 19:48 UTC|newest]
Thread overview: 7+ messages / expand[flat|nested] mbox.gz Atom feed top
2023-08-25 19:47 [COMMITTED V3 0/6] Support " Sandra Loosemore
2023-08-25 19:47 ` [COMMITTED V3 1/6] OpenMP: Add OMP_STRUCTURED_BLOCK and GIMPLE_OMP_STRUCTURED_BLOCK Sandra Loosemore
2023-08-25 19:47 ` [COMMITTED V3 2/6] OpenMP: C front end support for imperfectly-nested loops Sandra Loosemore
2023-08-25 19:47 ` [COMMITTED V3 3/6] OpenMP: C++ " Sandra Loosemore
2023-08-25 19:47 ` [COMMITTED V3 4/6] OpenMP: New C/C++ testcases for imperfectly nested loops Sandra Loosemore
2023-08-25 19:47 ` Sandra Loosemore [this message]
2023-08-25 19:47 ` [COMMITTED V3 6/6] OpenMP: Document support for imperfectly-nested loops Sandra Loosemore
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20230825194714.627157-6-sandra@codesourcery.com \
--to=sandra@codesourcery.com \
--cc=gcc-patches@gcc.gnu.org \
--cc=jakub@redhat.com \
--cc=tobias@codesourcery.com \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).