mirrors/gcc
1
0
Fork 0
mirror of https://gcc.gnu.org/git/gcc.git synced 2024-11-23 19:03:59 +08:00
Code Issues Actions Packages Projects Releases Wiki Activity

OpenMP: Fortran support for imperfectly-nested loops

Browse Source 
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.
This commit is contained in:
Sandra Loosemore 2023-08-24 17:35:01 +00:00
parent 410df0843d
commit b7c4a12a9d
21 changed files with 2057 additions and 107 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
gcc/fortran/gfortran.h
View File

@ -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;

761
gcc/fortran/openmp.cc
View File

@ -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);
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;
}
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);
}

7
gcc/fortran/trans-stmt.cc
View File

@ -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. */

6
gcc/testsuite/gfortran.dg/gomp/collapse1.f90
View File

@ -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)

10
gcc/testsuite/gfortran.dg/gomp/collapse2.f90
View File

@ -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

69
gcc/testsuite/gfortran.dg/gomp/imperfect-gotos.f90 Normal file
View File

@ -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

81
gcc/testsuite/gfortran.dg/gomp/imperfect-invalid-scope.f90 Normal file
View File

@ -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

39
gcc/testsuite/gfortran.dg/gomp/imperfect1.f90 Normal file
View File

@ -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

56
gcc/testsuite/gfortran.dg/gomp/imperfect2.f90 Normal file
View File

@ -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

45
gcc/testsuite/gfortran.dg/gomp/imperfect3.f90 Normal file
View File

@ -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

36
gcc/testsuite/gfortran.dg/gomp/imperfect4.f90 Normal file
View File

@ -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

85
gcc/testsuite/gfortran.dg/gomp/imperfect5.f90 Normal file
View File

@ -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

142
libgomp/testsuite/libgomp.fortran/imperfect-destructor.f90 Normal file
View File

@ -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

67
libgomp/testsuite/libgomp.fortran/imperfect1.f90 Normal file
View File

@ -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

102
libgomp/testsuite/libgomp.fortran/imperfect2.f90 Normal file
View File

@ -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

110
libgomp/testsuite/libgomp.fortran/imperfect3.f90 Normal file
View File

@ -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

121
libgomp/testsuite/libgomp.fortran/imperfect4.f90 Normal file
View File

@ -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

72
libgomp/testsuite/libgomp.fortran/target-imperfect1.f90 Normal file
View File

@ -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

110
libgomp/testsuite/libgomp.fortran/target-imperfect2.f90 Normal file
View File

@ -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

116
libgomp/testsuite/libgomp.fortran/target-imperfect3.f90 Normal file
View File

@ -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

126
libgomp/testsuite/libgomp.fortran/target-imperfect4.f90 Normal file
View File

@ -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