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 ("% 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 ("% 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 % " + "REDUCTION clause at %L", loc); + if (omp_clauses->sched_kind != OMP_SCHED_NONE) + gfc_error ("SCHEDULE clause specified together with % " + "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 % " - "REDUCTION clause at %L", loc); - if (code->ext.omp_clauses->sched_kind != OMP_SCHED_NONE) - gfc_error ("SCHEDULE clause specified together with % " - "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); } 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