aboutsummaryrefslogtreecommitdiff
path: root/gcc/fortran
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/fortran')
-rw-r--r--gcc/fortran/ChangeLog101
-rw-r--r--gcc/fortran/f95-lang.cc6
-rw-r--r--gcc/fortran/interface.cc37
-rw-r--r--gcc/fortran/iresolve.cc6
-rw-r--r--gcc/fortran/openmp.cc119
-rw-r--r--gcc/fortran/resolve.cc63
-rw-r--r--gcc/fortran/trans-decl.cc38
-rw-r--r--gcc/fortran/trans-expr.cc42
-rw-r--r--gcc/fortran/trans-intrinsic.cc7
-rw-r--r--gcc/fortran/trans-openmp.cc1007
-rw-r--r--gcc/fortran/trans-stmt.cc144
-rw-r--r--gcc/fortran/trans.h6
12 files changed, 1373 insertions, 203 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 9da9326..56325a9 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,104 @@
+2025-04-19 Steven G. Kargl <kargl@gcc.gnu.org>
+
+ PR fortran/119836
+ * resolve.cc (check_pure_function): Fix checking for
+ an impure subprogram within a DO CONCURRENT construct.
+ (pure_subroutine): Ditto.
+
+2025-04-16 Harald Anlauf <anlauf@gmx.de>
+
+ PR fortran/106948
+ * resolve.cc (gfc_pure_function): If a function has been resolved,
+ but esym is not yet set, look at its attributes to see whether it
+ is pure or elemental.
+
+2025-04-15 Tobias Burnus <tburnus@baylibre.com>
+
+ * f95-lang.cc (LANG_HOOKS_OMP_DEEP_MAPPING,
+ LANG_HOOKS_OMP_DEEP_MAPPING_P, LANG_HOOKS_OMP_DEEP_MAPPING_CNT):
+ Define.
+ * openmp.cc (gfc_match_omp_clause_reduction): Fix location setting.
+ (resolve_omp_clauses): Permit allocatable components, reject
+ them and polymorphic variables in PRIVATE/FIRSTPRIVATE.
+ * trans-decl.cc (add_clause): Set clause location.
+ * trans-openmp.cc (gfc_has_alloc_comps): Add ptr_ok and
+ shallow_alloc_only Boolean arguments.
+ (gfc_omp_replace_alloc_by_to_mapping): New.
+ (gfc_omp_private_outer_ref, gfc_walk_alloc_comps,
+ gfc_omp_clause_default_ctor, gfc_omp_clause_copy_ctor,
+ gfc_omp_clause_assign_op, gfc_omp_clause_dtor): Update call to it.
+ (gfc_omp_finish_clause): Minor cleanups, improve location data,
+ handle allocatable components.
+ (gfc_omp_deep_mapping_map, gfc_omp_deep_mapping_item,
+ gfc_omp_deep_mapping_comps, gfc_omp_gen_simple_loop,
+ gfc_omp_get_array_size, gfc_omp_elmental_loop,
+ gfc_omp_deep_map_kind_p, gfc_omp_deep_mapping_int_p,
+ gfc_omp_deep_mapping_p, gfc_omp_deep_mapping_do,
+ gfc_omp_deep_mapping_cnt, gfc_omp_deep_mapping): New.
+ (gfc_trans_omp_array_section): Save array descriptor in case
+ deep-mapping lang hook will need it.
+ (gfc_trans_omp_clauses): Likewise; use better clause location data.
+ * trans.h (gfc_omp_deep_mapping_p, gfc_omp_deep_mapping_cnt,
+ gfc_omp_deep_mapping): Add function prototypes.
+
+2025-04-13 Thomas Koenig <tkoenig@gcc.gnu.org>
+
+ PR fortran/119669
+ * interface.cc (compare_parameter): Error when mismatch between
+ formal argument as subroutine and function. If the dummy
+ argument is a known function, set its typespec.
+
+2025-04-12 Thomas Schwinge <tschwinge@baylibre.com>
+
+ PR fortran/101602
+ * trans-stmt.cc (gfc_trans_concurrent_locality_spec): Fix
+ 'static_assert'.
+
+2025-04-09 Harald Anlauf <anlauf@gmx.de>
+
+ PR fortran/119656
+ * interface.cc (gfc_compare_actual_formal): Fix front-end memleak
+ when searching for matching interfaces.
+ * trans-expr.cc (gfc_conv_procedure_call): If there is a formal
+ dummy corresponding to an absent argument, use its type, and only
+ fall back to inferred type otherwise.
+
+2025-04-09 Paul Thomas <pault@gcc.gnu.org>
+ and Harald Anlauf <anlauf@gcc.gnu.org>
+
+ PR fortran/119460
+ * iresolve.cc (generate_reduce_op_wrapper): Increase the size
+ of 'tname'. Change intent of 'a' and 'b' to intent_in.
+ * trans-decl.cc (add_argument_checking): Do not test artificial
+ formal symbols.
+ * trans-expr.cc (gfc_conv_procedure_call): Remove reduce_scalar
+ and the blocks triggered by it.
+ * trans-intrinsic.cc (gfc_conv_intrinsic_function): Set the
+ result of non-character, scalar reduce to be allocatable.
+
+2025-04-09 Tobias Burnus <tburnus@baylibre.com>
+
+ PR fortran/101602
+ * resolve.cc (resolve_locality_spec): Remove 'sorry, unimplemented'.
+ * trans-stmt.cc (struct symbol_and_tree_t): New.
+ (gfc_trans_concurrent_locality_spec): New.
+ (gfc_trans_forall_1): Call it; update to handle local and local_init.
+ * trans-decl.cc (gfc_start_saved_local_decls,
+ gfc_stop_saved_local_decls): New; moved code from ...
+ (gfc_process_block_locals): ... here. Call it.
+ * trans.h (gfc_start_saved_local_decls,
+ gfc_stop_saved_local_decls): Declare.
+
+2025-04-02 Sandra Loosemore <sloosemore@baylibre.com>
+
+ PR middle-end/118965
+ * openmp.cc (gfc_parser_omp_clause_init_modifiers): Fix some
+ inconsistent code indentation. Remove code for recognizing
+ clauses without modifiers. Diagnose prefer_type without a
+ following paren. Adjust error message for an unrecognized modifier.
+ Diagnose missing target/targetsync modifier.
+ (gfc_match_omp_init): Fix more inconsistent code indentation.
+
2025-03-28 Harald Anlauf <anlauf@gmx.de>
* check.cc (gfc_invalid_boz): Correct spelling of compiler flag in
diff --git a/gcc/fortran/f95-lang.cc b/gcc/fortran/f95-lang.cc
index 124d62f..1f09553 100644
--- a/gcc/fortran/f95-lang.cc
+++ b/gcc/fortran/f95-lang.cc
@@ -148,6 +148,9 @@ gfc_get_sarif_source_language (const char *)
#undef LANG_HOOKS_OMP_CLAUSE_LINEAR_CTOR
#undef LANG_HOOKS_OMP_CLAUSE_DTOR
#undef LANG_HOOKS_OMP_FINISH_CLAUSE
+#undef LANG_HOOKS_OMP_DEEP_MAPPING
+#undef LANG_HOOKS_OMP_DEEP_MAPPING_P
+#undef LANG_HOOKS_OMP_DEEP_MAPPING_CNT
#undef LANG_HOOKS_OMP_ALLOCATABLE_P
#undef LANG_HOOKS_OMP_SCALAR_TARGET_P
#undef LANG_HOOKS_OMP_SCALAR_P
@@ -188,6 +191,9 @@ gfc_get_sarif_source_language (const char *)
#define LANG_HOOKS_OMP_CLAUSE_LINEAR_CTOR gfc_omp_clause_linear_ctor
#define LANG_HOOKS_OMP_CLAUSE_DTOR gfc_omp_clause_dtor
#define LANG_HOOKS_OMP_FINISH_CLAUSE gfc_omp_finish_clause
+#define LANG_HOOKS_OMP_DEEP_MAPPING gfc_omp_deep_mapping
+#define LANG_HOOKS_OMP_DEEP_MAPPING_P gfc_omp_deep_mapping_p
+#define LANG_HOOKS_OMP_DEEP_MAPPING_CNT gfc_omp_deep_mapping_cnt
#define LANG_HOOKS_OMP_ALLOCATABLE_P gfc_omp_allocatable_p
#define LANG_HOOKS_OMP_SCALAR_P gfc_omp_scalar_p
#define LANG_HOOKS_OMP_SCALAR_TARGET_P gfc_omp_scalar_target_p
diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index 6258a41..1e552a3 100644
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -2534,16 +2534,33 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
gfc_find_symbol (actual_name, gsym->ns, 0, &global_asym);
if (global_asym != NULL)
{
- gcc_assert (formal->attr.function);
- if (!gfc_compare_types (&global_asym->ts, &formal->ts))
+ if (formal->attr.subroutine)
{
- gfc_error ("Type mismatch at %L passing global "
- "function %qs declared at %L (%s/%s)",
- &actual->where, actual_name, &gsym->where,
- gfc_typename (&global_asym->ts),
- gfc_dummy_typename (&formal->ts));
+ gfc_error ("Mismatch between subroutine and "
+ "function at %L", &actual->where);
return false;
}
+ else if (formal->attr.function)
+ {
+ if (!gfc_compare_types (&global_asym->ts,
+ &formal->ts))
+ {
+ gfc_error ("Type mismatch at %L passing global "
+ "function %qs declared at %L (%s/%s)",
+ &actual->where, actual_name,
+ &gsym->where,
+ gfc_typename (&global_asym->ts),
+ gfc_dummy_typename (&formal->ts));
+ return false;
+ }
+ }
+ else
+ {
+ /* The global symbol is a function. Set the formal
+ argument acordingly. */
+ formal->attr.function = 1;
+ formal->ts = global_asym->ts;
+ }
}
}
}
@@ -3382,7 +3399,11 @@ gfc_compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
return false;
}
else
- a->associated_dummy = get_nonintrinsic_dummy_arg (f);
+ {
+ if (a->associated_dummy)
+ free (a->associated_dummy);
+ a->associated_dummy = get_nonintrinsic_dummy_arg (f);
+ }
if (a->expr == NULL)
{
diff --git a/gcc/fortran/iresolve.cc b/gcc/fortran/iresolve.cc
index 8189d7a..858ffb1 100644
--- a/gcc/fortran/iresolve.cc
+++ b/gcc/fortran/iresolve.cc
@@ -2417,7 +2417,7 @@ generate_reduce_op_wrapper (gfc_expr *op)
gfc_symbol *operation = op->symtree->n.sym;
gfc_symbol *wrapper, *a, *b, *c;
gfc_symtree *st;
- char tname[GFC_MAX_SYMBOL_LEN+1];
+ char tname[2 * GFC_MAX_SYMBOL_LEN + 2];
char *name;
gfc_namespace *ns;
gfc_expr *e;
@@ -2462,7 +2462,7 @@ generate_reduce_op_wrapper (gfc_expr *op)
a->attr.flavor = FL_VARIABLE;
a->attr.dummy = 1;
a->attr.artificial = 1;
- a->attr.intent = INTENT_INOUT;
+ a->attr.intent = INTENT_IN;
wrapper->formal = gfc_get_formal_arglist ();
wrapper->formal->sym = a;
gfc_set_sym_referenced (a);
@@ -2476,7 +2476,7 @@ generate_reduce_op_wrapper (gfc_expr *op)
b->attr.dummy = 1;
b->attr.optional= 1;
b->attr.artificial = 1;
- b->attr.intent = INTENT_INOUT;
+ b->attr.intent = INTENT_IN;
wrapper->formal->next = gfc_get_formal_arglist ();
wrapper->formal->next->sym = b;
gfc_set_sym_referenced (b);
diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc
index 905980a..df82940 100644
--- a/gcc/fortran/openmp.cc
+++ b/gcc/fortran/openmp.cc
@@ -1588,7 +1588,7 @@ gfc_match_omp_clause_reduction (char pc, gfc_omp_clauses *c, bool openacc,
{
gfc_omp_namelist *p = gfc_get_omp_namelist (), **tl;
p->sym = n->sym;
- p->where = p->where;
+ p->where = n->where;
p->u.map.op = OMP_MAP_ALWAYS_TOFROM;
tl = &c->lists[OMP_LIST_MAP];
@@ -2138,10 +2138,8 @@ gfc_match_omp_prefer_type (char **type_str, int *type_str_len)
the 'interop' directive and the 'append_args' directive of 'declare variant'.
[prefer_type(...)][,][<target|targetsync>, ...])
- If is_init_clause, there might be no modifiers but variables like 'target';
- additionally, the modifier parsing ends with a ':'.
- If not is_init_clause (i.e. append_args), there must be modifiers and the
- parsing ends with ')'. */
+ If is_init_clause, the modifier parsing ends with a ':'.
+ If not is_init_clause (i.e. append_args), the parsing ends with ')'. */
static match
gfc_parser_omp_clause_init_modifiers (bool &target, bool &targetsync,
@@ -2153,9 +2151,10 @@ gfc_parser_omp_clause_init_modifiers (bool &target, bool &targetsync,
*type_str = NULL;
type_str_len = 0;
match m;
- locus old_loc = gfc_current_locus;
- do {
- if (gfc_match ("prefer_type ( ") == MATCH_YES)
+
+ do
+ {
+ if (gfc_match ("prefer_type ( ") == MATCH_YES)
{
if (*type_str)
{
@@ -2181,12 +2180,17 @@ gfc_parser_omp_clause_init_modifiers (bool &target, bool &targetsync,
}
return MATCH_ERROR;
}
- if (gfc_match ("targetsync ") == MATCH_YES)
+
+ if (gfc_match ("prefer_type ") == MATCH_YES)
+ {
+ gfc_error ("Expected %<(%> after %<prefer_type%> at %C");
+ return MATCH_ERROR;
+ }
+
+ if (gfc_match ("targetsync ") == MATCH_YES)
{
if (targetsync)
{
- /* Avoid the word 'modifier' as it could be also be no clauses and
- twice a variable named 'targetsync', which is also invalid. */
gfc_error ("Duplicate %<targetsync%> at %C");
return MATCH_ERROR;
}
@@ -2202,13 +2206,6 @@ gfc_parser_omp_clause_init_modifiers (bool &target, bool &targetsync,
}
if (gfc_match (": ") == MATCH_YES)
break;
- gfc_char_t c = gfc_peek_char ();
- if (!*type_str && (c == ')' || (gfc_current_form != FORM_FREE
- && (c == '_' || ISALPHA (c)))))
- {
- gfc_current_locus = old_loc;
- break;
- }
gfc_error ("Expected %<,%> or %<:%> at %C");
return MATCH_ERROR;
}
@@ -2231,25 +2228,21 @@ gfc_parser_omp_clause_init_modifiers (bool &target, bool &targetsync,
}
if (gfc_match (": ") == MATCH_YES)
break;
- gfc_char_t c = gfc_peek_char ();
- if (!*type_str && (c == ')' || (gfc_current_form != FORM_FREE
- && (c == '_' || ISALPHA (c)))))
- {
- gfc_current_locus = old_loc;
- break;
- }
gfc_error ("Expected %<,%> or %<:%> at %C");
return MATCH_ERROR;
}
- if (*type_str)
- {
- gfc_error ("Expected %<target%> or %<targetsync%> at %C");
- return MATCH_ERROR;
- }
- gfc_current_locus = old_loc;
- break;
+ gfc_error ("Expected %<prefer_type%>, %<target%>, or %<targetsync%> "
+ "at %C");
+ return MATCH_ERROR;
}
while (true);
+
+ if (!target && !targetsync)
+ {
+ gfc_error ("Missing required %<target%> and/or %<targetsync%> "
+ "modifier at %C");
+ return MATCH_ERROR;
+ }
return MATCH_YES;
}
@@ -2266,17 +2259,17 @@ gfc_match_omp_init (gfc_omp_namelist **list)
type_str_len, true) == MATCH_ERROR)
return MATCH_ERROR;
- gfc_omp_namelist **head = NULL;
- if (gfc_match_omp_variable_list ("", list, false, NULL, &head) != MATCH_YES)
- return MATCH_ERROR;
- for (gfc_omp_namelist *n = *head; n; n = n->next)
- {
- n->u.init.target = target;
- n->u.init.targetsync = targetsync;
- n->u.init.len = type_str_len;
- n->u2.init_interop = type_str;
- }
- return MATCH_YES;
+ gfc_omp_namelist **head = NULL;
+ if (gfc_match_omp_variable_list ("", list, false, NULL, &head) != MATCH_YES)
+ return MATCH_ERROR;
+ for (gfc_omp_namelist *n = *head; n; n = n->next)
+ {
+ n->u.init.target = target;
+ n->u.init.targetsync = targetsync;
+ n->u.init.len = type_str_len;
+ n->u2.init_interop = type_str;
+ }
+ return MATCH_YES;
}
@@ -9688,22 +9681,6 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
&& n->sym->as->type == AS_ASSUMED_SIZE)
gfc_error ("Assumed size array %qs in %s clause at %L",
n->sym->name, name, &n->where);
- if (!openacc
- && list == OMP_LIST_MAP
- && n->sym->ts.type == BT_DERIVED
- && n->sym->ts.u.derived->attr.alloc_comp)
- gfc_error ("List item %qs with allocatable components is not "
- "permitted in map clause at %L", n->sym->name,
- &n->where);
- if (!openacc
- && (list == OMP_LIST_MAP
- || list == OMP_LIST_FROM
- || list == OMP_LIST_TO)
- && ((n->expr && n->expr->ts.type == BT_CLASS)
- || (!n->expr && n->sym->ts.type == BT_CLASS)))
- gfc_warning (OPT_Wopenmp,
- "Mapping polymorphic list item at %L is "
- "unspecified behavior", &n->where);
if (list == OMP_LIST_MAP && !openacc)
switch (code->op)
{
@@ -10015,9 +9992,11 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
n->sym->name, name, &n->where);
if (!openacc
- && list == OMP_LIST_FIRSTPRIVATE
- && ((n->expr && n->expr->ts.type == BT_CLASS)
- || (!n->expr && n->sym->ts.type == BT_CLASS)))
+ && (list == OMP_LIST_PRIVATE
+ || list == OMP_LIST_FIRSTPRIVATE)
+ && ((n->sym->ts.type == BT_DERIVED
+ && n->sym->ts.u.derived->attr.alloc_comp)
+ || n->sym->ts.type == BT_CLASS))
switch (code->op)
{
case EXEC_OMP_TARGET:
@@ -10032,9 +10011,19 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
case EXEC_OMP_TARGET_TEAMS_LOOP:
- gfc_warning (OPT_Wopenmp,
- "FIRSTPRIVATE with polymorphic list item at "
- "%L is unspecified behavior", &n->where);
+ if (n->sym->ts.type == BT_DERIVED
+ && n->sym->ts.u.derived->attr.alloc_comp)
+ gfc_error ("Sorry, list item %qs at %L with allocatable"
+ " components is not yet supported in %s "
+ "clause", n->sym->name, &n->where,
+ list == OMP_LIST_PRIVATE ? "PRIVATE"
+ : "FIRSTPRIVATE");
+ else
+ gfc_error ("Polymorphic list item %qs at %L in %s "
+ "clause has unspecified behavior and "
+ "unsupported", n->sym->name, &n->where,
+ list == OMP_LIST_PRIVATE ? "PRIVATE"
+ : "FIRSTPRIVATE");
break;
default:
break;
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index cb36589..f03708e 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -3190,6 +3190,13 @@ gfc_pure_function (gfc_expr *e, const char **name)
|| e->value.function.isym->elemental;
*name = e->value.function.isym->name;
}
+ else if (e->symtree && e->symtree->n.sym && e->symtree->n.sym->attr.dummy)
+ {
+ /* The function has been resolved, but esym is not yet set.
+ This can happen with functions as dummy argument. */
+ pure = e->symtree->n.sym->attr.pure;
+ *name = e->symtree->n.sym->name;
+ }
else
{
/* Implicit functions are not pure. */
@@ -3253,14 +3260,30 @@ static bool check_pure_function (gfc_expr *e)
gfc_do_concurrent_flag = 0 when the check for an impure function
occurs. Check the stack to see if the source code has a nested
BLOCK construct. */
+
for (stack = cs_base; stack; stack = stack->prev)
{
- if (stack->current->op == EXEC_BLOCK) saw_block = true;
+ if (!saw_block && stack->current->op == EXEC_BLOCK)
+ {
+ saw_block = true;
+ continue;
+ }
+
if (saw_block && stack->current->op == EXEC_DO_CONCURRENT)
{
- gfc_error ("Reference to impure function at %L inside a "
- "DO CONCURRENT", &e->where);
- return false;
+ bool is_pure;
+ is_pure = (e->value.function.isym
+ && (e->value.function.isym->pure
+ || e->value.function.isym->elemental))
+ || (e->value.function.esym
+ && (e->value.function.esym->attr.pure
+ || e->value.function.esym->attr.elemental));
+ if (!is_pure)
+ {
+ gfc_error ("Reference to impure function at %L inside a "
+ "DO CONCURRENT", &e->where);
+ return false;
+ }
}
}
@@ -3656,16 +3679,29 @@ pure_subroutine (gfc_symbol *sym, const char *name, locus *loc)
/* A BLOCK construct within a DO CONCURRENT construct leads to
gfc_do_concurrent_flag = 0 when the check for an impure subroutine
- occurs. Check the stack to see if the source code has a nested
- BLOCK construct. */
+ occurs. Walk up the stack to see if the source code has a nested
+ construct. */
+
for (stack = cs_base; stack; stack = stack->prev)
{
- if (stack->current->op == EXEC_BLOCK) saw_block = true;
+ if (stack->current->op == EXEC_BLOCK)
+ {
+ saw_block = true;
+ continue;
+ }
+
if (saw_block && stack->current->op == EXEC_DO_CONCURRENT)
{
- gfc_error ("Subroutine call at %L in a DO CONCURRENT block "
- "is not PURE", loc);
- return false;
+
+ bool is_pure = true;
+ is_pure = sym->attr.pure || sym->attr.elemental;
+
+ if (!is_pure)
+ {
+ gfc_error ("Subroutine call at %L in a DO CONCURRENT block "
+ "is not PURE", loc);
+ return false;
+ }
}
}
@@ -8422,13 +8458,6 @@ resolve_locality_spec (gfc_code *code, gfc_namespace *ns)
plist = &((*plist)->next);
}
}
-
- if (code->ext.concur.locality[LOCALITY_LOCAL]
- || code->ext.concur.locality[LOCALITY_LOCAL_INIT])
- {
- gfc_error ("Sorry, LOCAL and LOCAL_INIT are not yet supported for "
- "%<do concurrent%> constructs at %L", &code->loc);
- }
}
/* Resolve a list of FORALL iterators. The FORALL index-name is constrained
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 8dd1c93..ddc4960 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -6546,7 +6546,7 @@ add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
message = _("Actual string length does not match the declared one"
" for dummy argument '%s' (%ld/%ld)");
}
- else if (fsym->as && fsym->as->rank != 0)
+ else if ((fsym->as && fsym->as->rank != 0) || fsym->attr.artificial)
continue;
else
{
@@ -6920,6 +6920,7 @@ add_clause (gfc_symbol *sym, gfc_omp_map_op map_op)
n = gfc_get_omp_namelist ();
n->sym = sym;
+ n->where = sym->declared_at;
n->u.map.op = map_op;
if (!module_oacc_clauses)
@@ -8361,23 +8362,17 @@ gfc_generate_block_data (gfc_namespace * ns)
rest_of_decl_compilation (decl, 1, 0);
}
-
-/* Process the local variables of a BLOCK construct. */
-
void
-gfc_process_block_locals (gfc_namespace* ns)
+gfc_start_saved_local_decls ()
{
- tree decl;
-
+ gcc_checking_assert (current_function_decl != NULL_TREE);
saved_local_decls = NULL_TREE;
- has_coarray_vars_or_accessors = caf_accessor_head != NULL;
-
- generate_local_vars (ns);
-
- if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars_or_accessors)
- generate_coarray_init (ns);
+}
- decl = nreverse (saved_local_decls);
+void
+gfc_stop_saved_local_decls ()
+{
+ tree decl = nreverse (saved_local_decls);
while (decl)
{
tree next;
@@ -8390,5 +8385,20 @@ gfc_process_block_locals (gfc_namespace* ns)
saved_local_decls = NULL_TREE;
}
+/* Process the local variables of a BLOCK construct. */
+
+void
+gfc_process_block_locals (gfc_namespace* ns)
+{
+ gfc_start_saved_local_decls ();
+ has_coarray_vars_or_accessors = caf_accessor_head != NULL;
+
+ generate_local_vars (ns);
+
+ if (flag_coarray == GFC_FCOARRAY_LIB && has_coarray_vars_or_accessors)
+ generate_coarray_init (ns);
+ gfc_stop_saved_local_decls ();
+}
+
#include "gt-fortran-trans-decl.h"
diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 4b90b06..62dd38d 100644
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -6753,12 +6753,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_intrinsic_sym *isym = expr && expr->rank ?
expr->value.function.isym : NULL;
- /* In order that the library function for intrinsic REDUCE be type and kind
- agnostic, the result is passed by reference. Allocatable components are
- handled within the OPERATION wrapper. */
- bool reduce_scalar = expr && !expr->rank && expr->value.function.isym
- && expr->value.function.isym->id == GFC_ISYM_REDUCE;
-
comp = gfc_get_proc_ptr_comp (expr);
bool elemental_proc = (comp
@@ -6931,10 +6925,18 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
{
/* Pass a NULL pointer for an absent arg. */
parmse.expr = null_pointer_node;
+
+ /* Is it an absent character dummy? */
+ bool absent_char = false;
gfc_dummy_arg * const dummy_arg = arg->associated_dummy;
- if (dummy_arg
- && gfc_dummy_arg_get_typespec (*dummy_arg).type
- == BT_CHARACTER)
+
+ /* Fall back to inferred type only if no formal. */
+ if (fsym)
+ absent_char = (fsym->ts.type == BT_CHARACTER);
+ else if (dummy_arg)
+ absent_char = (gfc_dummy_arg_get_typespec (*dummy_arg).type
+ == BT_CHARACTER);
+ if (absent_char)
parmse.string_length = build_int_cst (gfc_charlen_type_node,
0);
}
@@ -6960,9 +6962,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
|| !CLASS_DATA (fsym)->attr.allocatable));
gfc_init_se (&parmse, NULL);
parmse.expr = null_pointer_node;
- if (arg->associated_dummy
- && gfc_dummy_arg_get_typespec (*arg->associated_dummy).type
- == BT_CHARACTER)
+ if (fsym->ts.type == BT_CHARACTER)
parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
}
else if (fsym && fsym->ts.type == BT_CLASS
@@ -8596,16 +8596,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
else if (ts.type == BT_CHARACTER)
vec_safe_push (retargs, len);
}
- else if (reduce_scalar)
- {
- /* In order that the library function for intrinsic REDUCE be type and
- kind agnostic, the result is passed by reference. Allocatable
- components are handled within the OPERATION wrapper. */
- type = gfc_typenode_for_spec (&expr->ts);
- result = gfc_create_var (type, "sr");
- tmp = gfc_build_addr_expr (pvoid_type_node, result);
- vec_safe_push (retargs, tmp);
- }
gfc_free_interface_mapping (&mapping);
@@ -8821,14 +8811,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
gfc_add_expr_to_block (&se->pre, tmp);
}
}
- else if (reduce_scalar)
- {
- /* Even though the REDUCE intrinsic library function returns the result
- by reference, the scalar call passes the result as se->expr. */
- gfc_add_expr_to_block (&se->pre, se->expr);
- se->expr = result;
- gfc_add_block_to_block (&se->post, &post);
- }
else
{
/* For a function with a class array result, save the result as
diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc
index 6b55017..6ffc3e0 100644
--- a/gcc/fortran/trans-intrinsic.cc
+++ b/gcc/fortran/trans-intrinsic.cc
@@ -3883,6 +3883,13 @@ gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
append_args->quick_push (null_pointer_node);
}
}
+ /* Non-character scalar reduce returns a pointer to a result of size set by
+ the element size of 'array'. Setting 'sym' allocatable ensures that the
+ result is deallocated at the appropriate time. */
+ else if (expr->value.function.isym->id == GFC_ISYM_REDUCE
+ && expr->rank == 0 && expr->ts.type != BT_CHARACTER)
+ sym->attr.allocatable = 1;
+
gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
append_args);
diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc
index 03d9432..0b8150f 100644
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -25,6 +25,10 @@ along with GCC; see the file COPYING3. If not see
#include "options.h"
#include "tree.h"
#include "gfortran.h"
+#include "basic-block.h"
+#include "tree-ssa.h"
+#include "function.h"
+#include "gimple.h"
#include "gimple-expr.h"
#include "trans.h"
#include "stringpool.h"
@@ -41,6 +45,8 @@ along with GCC; see the file COPYING3. If not see
#include "omp-low.h"
#include "memmodel.h" /* For MEMMODEL_ enums. */
#include "dependency.h"
+#include "gimple-iterator.h" /* For gsi_iterator_update. */
+#include "gimplify-me.h" /* For force_gimple_operand. */
#undef GCC_DIAG_STYLE
#define GCC_DIAG_STYLE __gcc_tdiag__
@@ -375,22 +381,28 @@ gfc_omp_report_decl (tree decl)
return decl;
}
-/* Return true if TYPE has any allocatable components. */
+/* Return true if TYPE has any allocatable components;
+ if ptr_ok, the decl itself is permitted to have the POINTER attribute.
+ if shallow_alloc_only, returns only true if any of the fields is an
+ allocatable; called with true by gfc_omp_replace_alloc_by_to_mapping. */
static bool
-gfc_has_alloc_comps (tree type, tree decl)
+gfc_has_alloc_comps (tree type, tree decl, bool ptr_ok,
+ bool shallow_alloc_only=false)
{
tree field, ftype;
if (POINTER_TYPE_P (type))
{
- if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))
+ if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl)
+ || (ptr_ok && GFC_DECL_GET_SCALAR_POINTER (decl)))
type = TREE_TYPE (type);
else if (GFC_DECL_GET_SCALAR_POINTER (decl))
return false;
}
- if (GFC_DESCRIPTOR_TYPE_P (type)
+ if (!ptr_ok
+ && GFC_DESCRIPTOR_TYPE_P (type)
&& (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
|| GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
return false;
@@ -409,12 +421,51 @@ gfc_has_alloc_comps (tree type, tree decl)
if (GFC_DESCRIPTOR_TYPE_P (ftype)
&& GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
return true;
- if (gfc_has_alloc_comps (ftype, field))
+ if (!shallow_alloc_only
+ && gfc_has_alloc_comps (ftype, field, false))
return true;
}
return false;
}
+/* gfc_omp_replace_alloc_by_to_mapping is used with gfc_omp_deep_mapping... to
+ handle the following:
+
+ For map(alloc: dt), the array descriptors of allocatable components should
+ be mapped as 'to'; this could be done by (A) adding 'map(to: dt%alloc_comp)'
+ for each component (and avoiding to increment the reference count).
+ Or (B) by just mapping all of 'dt' as 'to'.
+
+ If 'dt' contains several allocatable components and not much other data,
+ (A) is more efficient. If 'dt' contains a large const-size array, (A) will
+ copy it to the device instead of only 'alloc'ating it.
+
+ IMPLEMENTATION CHOICE: We do (A). It avoids the ref-count issue and it is
+ expected that, for real-world code, derived types with allocatable
+ components only have few other components and either no const-size arrays.
+ This copying is done irrespectively whether the allocatables are allocated.
+
+ If users wanted to save memory, they have to use 'map(alloc:dt%comp)' as
+ also with 'map(alloc:dt)' all components get copied.
+
+ For the copy to the device, only allocatable arrays are relevant as their
+ the bounds are required; the pointer is set separately (GOMP_MAP_ATTACH)
+ and the only setting required for scalars. However, when later copying out
+ of the device, an unallocated allocatable must remain unallocated/NULL on
+ the host; to achieve this we also must have it set to NULL on the device
+ to avoid issues with uninitialized memory being copied back for the pointer
+ address. If we could set the pointer to NULL, gfc_has_alloc_comps's
+ shallow_alloc_only could be restricted to return true only for arrays.
+
+ We only need to return true if there are allocatable-array components. */
+
+static bool
+gfc_omp_replace_alloc_by_to_mapping (tree type, tree decl, bool ptr_ok)
+{
+ return gfc_has_alloc_comps (type, decl, ptr_ok, true);
+}
+
+
/* Return true if TYPE is polymorphic but not with pointer attribute. */
static bool
@@ -487,7 +538,7 @@ gfc_omp_private_outer_ref (tree decl)
if (GFC_DECL_GET_SCALAR_ALLOCATABLE (decl))
return true;
- if (gfc_has_alloc_comps (type, decl))
+ if (gfc_has_alloc_comps (type, decl, false))
return true;
return false;
@@ -627,7 +678,7 @@ gfc_walk_alloc_comps (tree decl, tree dest, tree var,
{
tree ftype = TREE_TYPE (field);
tree declf, destf = NULL_TREE;
- bool has_alloc_comps = gfc_has_alloc_comps (ftype, field);
+ bool has_alloc_comps = gfc_has_alloc_comps (ftype, field, false);
if ((!GFC_DESCRIPTOR_TYPE_P (ftype)
|| GFC_TYPE_ARRAY_AKIND (ftype) != GFC_ARRAY_ALLOCATABLE)
&& !GFC_DECL_GET_SCALAR_ALLOCATABLE (field)
@@ -751,7 +802,7 @@ gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
&& (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
|| !POINTER_TYPE_P (type)))
{
- if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
+ if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false))
{
gcc_assert (outer);
gfc_start_block (&block);
@@ -804,7 +855,7 @@ gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer)
else
gfc_add_modify (&cond_block, unshare_expr (decl),
fold_convert (TREE_TYPE (decl), ptr));
- if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
+ if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false))
{
tree tem = gfc_walk_alloc_comps (outer, decl,
OMP_CLAUSE_DECL (clause),
@@ -945,7 +996,7 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
&& (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
|| !POINTER_TYPE_P (type)))
{
- if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
+ if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false))
{
gfc_start_block (&block);
gfc_add_modify (&block, dest, src);
@@ -1004,7 +1055,7 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src)
builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr,
srcptr, size);
gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call));
- if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
+ if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false))
{
tree tem = gfc_walk_alloc_comps (src, dest,
OMP_CLAUSE_DECL (clause),
@@ -1049,7 +1100,7 @@ gfc_omp_clause_assign_op (tree clause, tree dest, tree src)
&& (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
|| !POINTER_TYPE_P (type)))
{
- if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
+ if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false))
{
gfc_start_block (&block);
/* First dealloc any allocatable components in DEST. */
@@ -1071,7 +1122,7 @@ gfc_omp_clause_assign_op (tree clause, tree dest, tree src)
gfc_start_block (&block);
- if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
+ if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false))
{
then_b = gfc_walk_alloc_comps (dest, NULL_TREE, OMP_CLAUSE_DECL (clause),
WALK_ALLOC_COMPS_DTOR);
@@ -1186,7 +1237,7 @@ gfc_omp_clause_assign_op (tree clause, tree dest, tree src)
builtin_decl_explicit (BUILT_IN_MEMCPY), 3, ptr,
srcptr, size);
gfc_add_expr_to_block (&cond_block, fold_convert (void_type_node, call));
- if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
+ if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false))
{
tree tem = gfc_walk_alloc_comps (src, dest,
OMP_CLAUSE_DECL (clause),
@@ -1438,7 +1489,7 @@ gfc_omp_clause_dtor (tree clause, tree decl)
&& (!GFC_DECL_GET_SCALAR_ALLOCATABLE (OMP_CLAUSE_DECL (clause))
|| !POINTER_TYPE_P (type)))
{
- if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
+ if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false))
return gfc_walk_alloc_comps (decl, NULL_TREE,
OMP_CLAUSE_DECL (clause),
WALK_ALLOC_COMPS_DTOR);
@@ -1458,7 +1509,7 @@ gfc_omp_clause_dtor (tree clause, tree decl)
tem = gfc_call_free (decl);
tem = gfc_omp_unshare_expr (tem);
- if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause)))
+ if (gfc_has_alloc_comps (type, OMP_CLAUSE_DECL (clause), false))
{
stmtblock_t block;
tree then_b;
@@ -1538,6 +1589,7 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc)
return;
tree decl = OMP_CLAUSE_DECL (c);
+ location_t loc = OMP_CLAUSE_LOCATION (c);
/* Assumed-size arrays can't be mapped implicitly, they have to be
mapped explicitly using array sections. */
@@ -1553,13 +1605,9 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc)
return;
}
- if (!openacc && GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
- warning_at (OMP_CLAUSE_LOCATION (c), OPT_Wopenmp,
- "Implicit mapping of polymorphic variable %qD is "
- "unspecified behavior", decl);
-
tree c2 = NULL_TREE, c3 = NULL_TREE, c4 = NULL_TREE;
tree present = gfc_omp_check_optional_argument (decl, true);
+ tree orig_decl = NULL_TREE;
if (POINTER_TYPE_P (TREE_TYPE (decl)))
{
if (!gfc_omp_privatize_by_reference (decl)
@@ -1568,7 +1616,7 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc)
&& !GFC_DECL_CRAY_POINTEE (decl)
&& !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
return;
- tree orig_decl = decl;
+ orig_decl = decl;
c4 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (c4, GOMP_MAP_POINTER);
@@ -1579,16 +1627,16 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc)
&& (GFC_DECL_GET_SCALAR_POINTER (orig_decl)
|| GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl)))
{
- c2 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
+ c2 = build_omp_clause (loc, OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_POINTER);
- OMP_CLAUSE_DECL (c2) = decl;
+ OMP_CLAUSE_DECL (c2) = unshare_expr (decl);
OMP_CLAUSE_SIZE (c2) = size_int (0);
stmtblock_t block;
gfc_start_block (&block);
- tree ptr = decl;
- ptr = gfc_build_cond_assign_expr (&block, present, decl,
- null_pointer_node);
+ tree ptr = gfc_build_cond_assign_expr (&block, present,
+ unshare_expr (decl),
+ null_pointer_node);
gimplify_and_add (gfc_finish_block (&block), pre_p);
ptr = build_fold_indirect_ref (ptr);
OMP_CLAUSE_DECL (c) = ptr;
@@ -1605,10 +1653,10 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc)
{
c3 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (c3, GOMP_MAP_POINTER);
- OMP_CLAUSE_DECL (c3) = unshare_expr (decl);
+ OMP_CLAUSE_DECL (c3) = decl;
OMP_CLAUSE_SIZE (c3) = size_int (0);
decl = build_fold_indirect_ref (decl);
- OMP_CLAUSE_DECL (c) = decl;
+ OMP_CLAUSE_DECL (c) = unshare_expr (decl);
}
}
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
@@ -1634,7 +1682,7 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc)
gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
ptr = build_fold_indirect_ref (ptr);
OMP_CLAUSE_DECL (c) = ptr;
- c2 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
+ c2 = build_omp_clause (loc, OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_TO_PSET);
if (present)
{
@@ -1651,7 +1699,7 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc)
: GOMP_MAP_POINTER);
if (present)
{
- ptr = gfc_conv_descriptor_data_get (decl);
+ ptr = gfc_conv_descriptor_data_get (unshare_expr (decl));
ptr = gfc_build_addr_expr (NULL, ptr);
ptr = gfc_build_cond_assign_expr (&block, present,
ptr, null_pointer_node);
@@ -1664,6 +1712,17 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc)
tree size = create_tmp_var (gfc_array_index_type);
tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type));
elemsz = fold_convert (gfc_array_index_type, elemsz);
+
+ if (orig_decl == NULL_TREE)
+ orig_decl = decl;
+ if (!openacc
+ && gfc_has_alloc_comps (type, orig_decl, true))
+ {
+ /* Save array descriptor for use in gfc_omp_deep_mapping{,_p,_cnt};
+ force evaluate to ensure that it is not gimplified + is a decl. */
+ gfc_allocate_lang_decl (size);
+ GFC_DECL_SAVED_DESCRIPTOR (size) = orig_decl;
+ }
enum gfc_array_kind akind = GFC_TYPE_ARRAY_AKIND (type);
if (akind == GFC_ARRAY_ALLOCATABLE
|| akind == GFC_ARRAY_POINTER
@@ -1692,14 +1751,14 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc)
else_b = gfc_finish_block (&cond_block);
tem = gfc_conv_descriptor_data_get (unshare_expr (decl));
tem = fold_convert (pvoid_type_node, tem);
- cond = fold_build2_loc (input_location, NE_EXPR,
+ cond = fold_build2_loc (loc, NE_EXPR,
boolean_type_node, tem, null_pointer_node);
if (present)
{
- cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR,
+ cond = fold_build2_loc (loc, TRUTH_ANDIF_EXPR,
boolean_type_node, present, cond);
}
- gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR,
+ gfc_add_expr_to_block (&block, build3_loc (loc, COND_EXPR,
void_type_node, cond,
then_b, else_b));
}
@@ -1739,11 +1798,30 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc)
tree stmt = gfc_finish_block (&block);
gimplify_and_add (stmt, pre_p);
}
+ else
+ {
+ if (OMP_CLAUSE_SIZE (c) == NULL_TREE)
+ OMP_CLAUSE_SIZE (c)
+ = DECL_P (decl) ? DECL_SIZE_UNIT (decl)
+ : TYPE_SIZE_UNIT (TREE_TYPE (decl));
+
+ tree type = TREE_TYPE (decl);
+ if (POINTER_TYPE_P (type) && POINTER_TYPE_P (TREE_TYPE (type)))
+ type = TREE_TYPE (type);
+ if (!openacc
+ && orig_decl != NULL_TREE
+ && gfc_has_alloc_comps (type, orig_decl, true))
+ {
+ /* Save array descriptor for use in gfc_omp_deep_mapping{,_p,_cnt};
+ force evaluate to ensure that it is not gimplified + is a decl. */
+ tree size = create_tmp_var (TREE_TYPE (OMP_CLAUSE_SIZE (c)));
+ gfc_allocate_lang_decl (size);
+ GFC_DECL_SAVED_DESCRIPTOR (size) = orig_decl;
+ gimplify_assign (size, OMP_CLAUSE_SIZE (c), pre_p);
+ OMP_CLAUSE_SIZE (c) = size;
+ }
+ }
tree last = c;
- if (OMP_CLAUSE_SIZE (c) == NULL_TREE)
- OMP_CLAUSE_SIZE (c)
- = DECL_P (decl) ? DECL_SIZE_UNIT (decl)
- : TYPE_SIZE_UNIT (TREE_TYPE (decl));
if (gimplify_expr (&OMP_CLAUSE_SIZE (c), pre_p,
NULL, is_gimple_val, fb_rvalue) == GS_ERROR)
OMP_CLAUSE_SIZE (c) = size_int (0);
@@ -1767,6 +1845,715 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc)
}
+/* map(<flag>: data [len: <size>])
+ map(attach: &data [bias: <bias>])
+ offset += 2; offset_data += 2 */
+static void
+gfc_omp_deep_mapping_map (tree data, tree size, unsigned HOST_WIDE_INT tkind,
+ location_t loc, tree data_array, tree sizes_array,
+ tree kinds_array, tree offset_data, tree offset,
+ gimple_seq *seq, const gimple *ctx)
+{
+ tree one = build_int_cst (size_type_node, 1);
+
+ STRIP_NOPS (data);
+ if (!POINTER_TYPE_P (TREE_TYPE (data)))
+ {
+ gcc_assert (TREE_CODE (data) == INDIRECT_REF);
+ data = TREE_OPERAND (data, 0);
+ }
+
+ /* data_array[offset_data] = data; */
+ tree tmp = build4 (ARRAY_REF, TREE_TYPE (TREE_TYPE (data_array)),
+ unshare_expr (data_array), offset_data,
+ NULL_TREE, NULL_TREE);
+ gimplify_assign (tmp, data, seq);
+
+ /* offset_data++ */
+ tmp = build2_loc (loc, PLUS_EXPR, size_type_node, offset_data, one);
+ gimplify_assign (offset_data, tmp, seq);
+
+ /* data_array[offset_data] = &data; */
+ tmp = build4 (ARRAY_REF, TREE_TYPE (TREE_TYPE (data_array)),
+ unshare_expr (data_array),
+ offset_data, NULL_TREE, NULL_TREE);
+ gimplify_assign (tmp, build_fold_addr_expr (data), seq);
+
+ /* offset_data++ */
+ tmp = build2_loc (loc, PLUS_EXPR, size_type_node, offset_data, one);
+ gimplify_assign (offset_data, tmp, seq);
+
+ /* sizes_array[offset] = size */
+ tmp = build2_loc (loc, MULT_EXPR, size_type_node,
+ TYPE_SIZE_UNIT (size_type_node), offset);
+ tmp = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (sizes_array),
+ sizes_array, tmp);
+ gimple_seq seq2 = NULL;
+ tmp = force_gimple_operand (tmp, &seq2, true, NULL_TREE);
+ gimple_seq_add_seq (seq, seq2);
+ tmp = build_fold_indirect_ref_loc (loc, tmp);
+ gimplify_assign (tmp, size, seq);
+
+ /* FIXME: tkind |= talign << talign_shift; */
+ /* kinds_array[offset] = tkind. */
+ tmp = build2_loc (loc, MULT_EXPR, size_type_node,
+ TYPE_SIZE_UNIT (short_unsigned_type_node), offset);
+ tmp = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (kinds_array),
+ kinds_array, tmp);
+ seq2 = NULL;
+ tmp = force_gimple_operand (tmp, &seq2, true, NULL_TREE);
+ gimple_seq_add_seq (seq, seq2);
+ tmp = build_fold_indirect_ref_loc (loc, tmp);
+ gimplify_assign (tmp, build_int_cst (short_unsigned_type_node, tkind), seq);
+
+ /* offset++ */
+ tmp = build2_loc (loc, PLUS_EXPR, size_type_node, offset, one);
+ gimplify_assign (offset, tmp, seq);
+
+ /* sizes_array[offset] = bias (= 0). */
+ tmp = build2_loc (loc, MULT_EXPR, size_type_node,
+ TYPE_SIZE_UNIT (size_type_node), offset);
+ tmp = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (sizes_array),
+ sizes_array, tmp);
+ seq2 = NULL;
+ tmp = force_gimple_operand (tmp, &seq2, true, NULL_TREE);
+ gimple_seq_add_seq (seq, seq2);
+ tmp = build_fold_indirect_ref_loc (loc, tmp);
+ gimplify_assign (tmp, build_zero_cst (size_type_node), seq);
+
+ gcc_assert (gimple_code (ctx) == GIMPLE_OMP_TARGET);
+ tkind = (gimple_omp_target_kind (ctx) == GF_OMP_TARGET_KIND_EXIT_DATA
+ ? GOMP_MAP_DETACH : GOMP_MAP_ATTACH);
+
+ /* kinds_array[offset] = tkind. */
+ tmp = build2_loc (loc, MULT_EXPR, size_type_node,
+ TYPE_SIZE_UNIT (short_unsigned_type_node), offset);
+ tmp = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (kinds_array),
+ kinds_array, tmp);
+ seq2 = NULL;
+ tmp = force_gimple_operand (tmp, &seq2, true, NULL_TREE);
+ gimple_seq_add_seq (seq, seq2);
+ tmp = build_fold_indirect_ref_loc (loc, tmp);
+ gimplify_assign (tmp, build_int_cst (short_unsigned_type_node, tkind), seq);
+
+ /* offset++ */
+ tmp = build2_loc (loc, PLUS_EXPR, size_type_node, offset, one);
+ gimplify_assign (offset, tmp, seq);
+}
+
+static void gfc_omp_deep_mapping_item (bool, bool, bool, location_t, tree,
+ tree *, unsigned HOST_WIDE_INT, tree,
+ tree, tree, tree, tree, tree,
+ gimple_seq *, const gimple *, bool *);
+
+/* Map allocatable components. */
+static void
+gfc_omp_deep_mapping_comps (bool is_cnt, location_t loc, tree decl,
+ tree *token, unsigned HOST_WIDE_INT tkind,
+ tree data_array, tree sizes_array, tree kinds_array,
+ tree offset_data, tree offset, tree num,
+ gimple_seq *seq, const gimple *ctx,
+ bool *poly_warned)
+{
+ tree type = TREE_TYPE (decl);
+ if (TREE_CODE (type) != RECORD_TYPE)
+ return;
+ for (tree field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
+ {
+ type = TREE_TYPE (field);
+ if (gfc_is_polymorphic_nonptr (type)
+ || GFC_DECL_GET_SCALAR_ALLOCATABLE (field)
+ || (GFC_DESCRIPTOR_TYPE_P (type)
+ && GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE))
+ {
+ tree tmp = fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field),
+ decl, field, NULL_TREE);
+ gfc_omp_deep_mapping_item (is_cnt, true, true, loc, tmp, token,
+ tkind, data_array, sizes_array,
+ kinds_array, offset_data, offset, num,
+ seq, ctx, poly_warned);
+ }
+ else if (GFC_DECL_GET_SCALAR_POINTER (field)
+ || GFC_DESCRIPTOR_TYPE_P (type))
+ continue;
+ else if (gfc_has_alloc_comps (TREE_TYPE (field), field, false))
+ {
+ tree tmp = fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field),
+ decl, field, NULL_TREE);
+ if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
+ gfc_omp_deep_mapping_item (is_cnt, false, false, loc, tmp,
+ token, tkind, data_array, sizes_array,
+ kinds_array, offset_data, offset, num,
+ seq, ctx, poly_warned);
+ else
+ gfc_omp_deep_mapping_comps (is_cnt, loc, tmp, token, tkind,
+ data_array, sizes_array, kinds_array,
+ offset_data, offset, num, seq, ctx,
+ poly_warned);
+ }
+ }
+}
+
+static void
+gfc_omp_gen_simple_loop (tree var, tree begin, tree end, enum tree_code cond,
+ tree step, location_t loc, gimple_seq *seq1,
+ gimple_seq *seq2)
+{
+ tree tmp;
+
+ /* var = begin. */
+ gimplify_assign (var, begin, seq1);
+
+ /* Loop: for (var = begin; var <cond> end; var += step). */
+ tree label_loop = create_artificial_label (loc);
+ tree label_cond = create_artificial_label (loc);
+
+ gimplify_and_add (fold_build1_loc (loc, GOTO_EXPR, void_type_node,
+ label_cond), seq1);
+ gimple_seq_add_stmt (seq1, gimple_build_label (label_loop));
+
+ /* Everything above is seq1; place loop body here. */
+
+ /* End of loop body -> put into seq2. */
+ tmp = fold_build2_loc (loc, PLUS_EXPR, TREE_TYPE (var), var, step);
+ gimplify_assign (var, tmp, seq2);
+ gimple_seq_add_stmt (seq2, gimple_build_label (label_cond));
+ tmp = fold_build2_loc (loc, cond, boolean_type_node, var, end);
+ tmp = build3_v (COND_EXPR, tmp, build1_v (GOTO_EXPR, label_loop),
+ build_empty_stmt (loc));
+ gimplify_and_add (tmp, seq2);
+}
+
+/* Return size variable with the size of an array. */
+static tree
+gfc_omp_get_array_size (location_t loc, tree desc, gimple_seq *seq)
+{
+ tree tmp;
+ gimple_seq seq1 = NULL, seq2 = NULL;
+ tree size = build_decl (loc, VAR_DECL, create_tmp_var_name ("size"),
+ size_type_node);
+ tree extent = build_decl (loc, VAR_DECL, create_tmp_var_name ("extent"),
+ gfc_array_index_type);
+ tree idx = build_decl (loc, VAR_DECL, create_tmp_var_name ("idx"),
+ signed_char_type_node);
+
+ tree begin = build_zero_cst (signed_char_type_node);
+ tree end;
+ if (GFC_TYPE_ARRAY_AKIND (TREE_TYPE (desc)) == GFC_ARRAY_ASSUMED_SHAPE_CONT
+ || GFC_TYPE_ARRAY_AKIND (TREE_TYPE (desc)) == GFC_ARRAY_ASSUMED_SHAPE)
+ end = gfc_conv_descriptor_rank (desc);
+ else
+ end = build_int_cst (signed_char_type_node,
+ GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)));
+ tree step = build_int_cst (signed_char_type_node, 1);
+
+ /* size = 0
+ for (idx = 0; idx < rank; idx++)
+ extent = gfc->dim[i].ubound - gfc->dim[i].lbound + 1
+ if (extent < 0) extent = 0
+ size *= extent. */
+ gimplify_assign (size, build_int_cst (size_type_node, 1), seq);
+
+ gfc_omp_gen_simple_loop (idx, begin, end, LT_EXPR, step, loc, &seq1, &seq2);
+ gimple_seq_add_seq (seq, seq1);
+
+ tmp = fold_build2_loc (loc, MINUS_EXPR, gfc_array_index_type,
+ gfc_conv_descriptor_ubound_get (desc, idx),
+ gfc_conv_descriptor_lbound_get (desc, idx));
+ tmp = fold_build2_loc (loc, PLUS_EXPR, gfc_array_index_type,
+ tmp, gfc_index_one_node);
+ gimplify_assign (extent, tmp, seq);
+ tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node,
+ extent, gfc_index_zero_node);
+ tmp = build3_v (COND_EXPR, tmp,
+ fold_build2_loc (loc, MODIFY_EXPR,
+ gfc_array_index_type,
+ extent, gfc_index_zero_node),
+ build_empty_stmt (loc));
+ gimplify_and_add (tmp, seq);
+ /* size *= extent. */
+ gimplify_assign (size, fold_build2_loc (loc, MULT_EXPR, size_type_node, size,
+ fold_convert (size_type_node,
+ extent)), seq);
+ gimple_seq_add_seq (seq, seq2);
+ return size;
+}
+
+/* Generate loop to access every array element; takes addr of first element
+ (decl's data comp); returns loop code in seq1 + seq2
+ and the pointer to the element as return value. */
+static tree
+gfc_omp_elmental_loop (location_t loc, tree decl, tree size, tree elem_len,
+ gimple_seq *seq1, gimple_seq *seq2)
+{
+ tree idx = build_decl (loc, VAR_DECL, create_tmp_var_name ("idx"),
+ size_type_node);
+ tree begin = build_zero_cst (size_type_node);
+ tree end = size;
+ tree step = build_int_cst (size_type_node, 1);
+ tree ptr;
+
+ gfc_omp_gen_simple_loop (idx, begin, end, LT_EXPR, step, loc, seq1, seq2);
+
+ tree type = TREE_TYPE (decl);
+ if (POINTER_TYPE_P (type))
+ {
+ type = TREE_TYPE (type);
+ gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
+ decl = fold_convert (build_pointer_type (TREE_TYPE (type)), decl);
+ }
+ else
+ {
+ gcc_assert (TREE_CODE (type) == ARRAY_TYPE);
+ decl = build_fold_addr_expr_loc (loc, decl);
+ }
+ decl = fold_convert (build_pointer_type (TREE_TYPE (type)), decl);
+ tree tmp = build2_loc (loc, MULT_EXPR, size_type_node, idx,
+ fold_convert (size_type_node, elem_len));
+ ptr = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (decl), decl, tmp);
+ gimple_seq seq3 = NULL;
+ ptr = force_gimple_operand (ptr, &seq3, true, NULL_TREE);
+ gimple_seq_add_seq (seq1, seq3);
+
+ return ptr;
+}
+
+
+/* If do_copy, copy data pointer and vptr (if applicable) as well.
+ Otherwise, only handle allocatable components.
+ do_copy == false can happen only with nonpolymorphic arguments
+ to a copy clause.
+ if (is_cnt) token ... offset is ignored and num is used, otherwise
+ num is NULL_TREE and unused. */
+
+static void
+gfc_omp_deep_mapping_item (bool is_cnt, bool do_copy, bool do_alloc_check,
+ location_t loc, tree decl, tree *token,
+ unsigned HOST_WIDE_INT tkind, tree data_array,
+ tree sizes_array, tree kinds_array, tree offset_data,
+ tree offset, tree num, gimple_seq *seq,
+ const gimple *ctx, bool *poly_warned)
+{
+ tree tmp;
+ tree type = TREE_TYPE (decl);
+ if (POINTER_TYPE_P (type))
+ type = TREE_TYPE (type);
+ tree end_label = NULL_TREE;
+ tree size = NULL_TREE, elem_len = NULL_TREE;
+
+ bool poly = gfc_is_polymorphic_nonptr (type);
+ if (poly && is_cnt && !*poly_warned)
+ {
+ if (gfc_is_unlimited_polymorphic_nonptr (type))
+ error_at (loc,
+ "Mapping of unlimited polymorphic list item %qD is "
+ "unspecified behavior and unsupported", decl);
+
+ else
+ warning_at (loc, OPT_Wopenmp,
+ "Mapping of polymorphic list item %qD is "
+ "unspecified behavior", decl);
+ *poly_warned = true;
+ }
+ if (do_alloc_check)
+ {
+ tree then_label = create_artificial_label (loc);
+ end_label = create_artificial_label (loc);
+ tmp = decl;
+ if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE
+ || (POINTER_TYPE_P (TREE_TYPE (tmp))
+ && (POINTER_TYPE_P (TREE_TYPE (TREE_TYPE (tmp)))
+ || GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (tmp))))))
+ tmp = build_fold_indirect_ref_loc (loc, tmp);
+ if (poly)
+ tmp = gfc_class_data_get (tmp);
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+ tmp = gfc_conv_descriptor_data_get (tmp);
+ gimple_seq seq2 = NULL;
+ tmp = force_gimple_operand (tmp, &seq2, true, NULL_TREE);
+ gimple_seq_add_seq (seq, seq2);
+
+ gimple_seq_add_stmt (seq,
+ gimple_build_cond (NE_EXPR, tmp, null_pointer_node,
+ then_label, end_label));
+ gimple_seq_add_stmt (seq, gimple_build_label (then_label));
+ }
+ tree class_decl = decl;
+ if (poly)
+ {
+ decl = gfc_class_data_get (decl);
+ type = TREE_TYPE (decl);
+ }
+ if (POINTER_TYPE_P (TREE_TYPE (decl)))
+ {
+ decl = build_fold_indirect_ref (decl);
+ type = TREE_TYPE (decl);
+ }
+
+ if (is_cnt && do_copy)
+ {
+ tree tmp = fold_build2_loc (loc, PLUS_EXPR, size_type_node,
+ num, build_int_cst (size_type_node, 1));
+ gimplify_assign (num, tmp, seq);
+ }
+ else if (do_copy)
+ {
+ /* copy data pointer */
+ tree bytesize;
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
+ {
+ /* TODO: Optimization: Shouldn't this be an expr. const, except for
+ deferred-length strings. (Cf. also below). */
+ elem_len = (poly ? gfc_class_vtab_size_get (class_decl)
+ : gfc_conv_descriptor_elem_len (decl));
+ tmp = (POINTER_TYPE_P (TREE_TYPE (decl))
+ ? build_fold_indirect_ref (decl) : decl);
+ size = gfc_omp_get_array_size (loc, tmp, seq);
+ bytesize = fold_build2_loc (loc, MULT_EXPR, size_type_node,
+ fold_convert (size_type_node, size),
+ fold_convert (size_type_node, elem_len));
+ tmp = gfc_conv_descriptor_data_get (decl);
+ }
+ else if (poly)
+ {
+ tmp = decl;
+ bytesize = fold_convert (size_type_node,
+ gfc_class_vtab_size_get (class_decl));
+ }
+ else
+ {
+ tmp = decl;
+ bytesize = TYPE_SIZE_UNIT (TREE_TYPE (decl));
+ }
+ unsigned HOST_WIDE_INT tkind2 = tkind;
+ if (!is_cnt
+ && (tkind == GOMP_MAP_ALLOC
+ || (tkind == GOMP_MAP_FROM
+ && (gimple_omp_target_kind (ctx)
+ != GF_OMP_TARGET_KIND_EXIT_DATA)))
+ && gfc_omp_replace_alloc_by_to_mapping (TREE_TYPE (decl), decl, true))
+ tkind2 = tkind == GOMP_MAP_ALLOC ? GOMP_MAP_TO : GOMP_MAP_TOFROM;
+
+ gfc_omp_deep_mapping_map (tmp, bytesize, tkind2, loc, data_array,
+ sizes_array, kinds_array, offset_data,
+ offset, seq, ctx);
+ }
+
+ tmp = decl;
+ if (POINTER_TYPE_P (TREE_TYPE (decl)))
+ while (TREE_CODE (tmp) == COMPONENT_REF || TREE_CODE (tmp) == ARRAY_REF)
+ tmp = TREE_OPERAND (tmp, TREE_CODE (tmp) == COMPONENT_REF ? 1 : 0);
+ if (poly || gfc_has_alloc_comps (type, tmp, true))
+ {
+ gimple_seq seq2 = NULL;
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)))
+ {
+ if (elem_len == NULL_TREE)
+ {
+ elem_len = gfc_conv_descriptor_elem_len (decl);
+ size = fold_convert (size_type_node,
+ gfc_omp_get_array_size (loc, decl, seq));
+ }
+ decl = gfc_conv_descriptor_data_get (decl);
+ decl = gfc_omp_elmental_loop (loc, decl, size, elem_len, seq, &seq2);
+ decl = build_fold_indirect_ref_loc (loc, decl);
+ }
+ else if (TREE_CODE (TREE_TYPE (tmp)) == ARRAY_TYPE)
+ {
+ type = TREE_TYPE (tmp);
+ /* FIXME: PR95868 - for var%str of deferred length, elem_len == 0;
+ len is stored as var%_str_length, but not in GFC_DECL_STRING_LEN
+ nor in TYPE_SIZE_UNIT as expression. */
+ elem_len = TYPE_SIZE_UNIT (TREE_TYPE (type));
+ size = fold_convert (size_type_node, GFC_TYPE_ARRAY_SIZE (type));
+ decl = gfc_omp_elmental_loop (loc, decl, size, elem_len, seq, &seq2);
+ decl = build_fold_indirect_ref_loc (loc, decl);
+ }
+ else if (POINTER_TYPE_P (TREE_TYPE (decl)))
+ decl = build_fold_indirect_ref (decl);
+
+ gfc_omp_deep_mapping_comps (is_cnt, loc, decl, token, tkind,
+ data_array, sizes_array, kinds_array,
+ offset_data, offset, num, seq, ctx,
+ poly_warned);
+ gimple_seq_add_seq (seq, seq2);
+ }
+ if (end_label)
+ gimple_seq_add_stmt (seq, gimple_build_label (end_label));
+}
+
+
+/* Which map types to check/handle for deep mapping. */
+static bool
+gfc_omp_deep_map_kind_p (tree clause)
+{
+ switch (OMP_CLAUSE_CODE (clause))
+ {
+ case OMP_CLAUSE_MAP:
+ break;
+ case OMP_CLAUSE_FIRSTPRIVATE:
+ case OMP_CLAUSE_TO:
+ case OMP_CLAUSE_FROM:
+ return true;
+ default:
+ gcc_unreachable ();
+ }
+
+ switch (OMP_CLAUSE_MAP_KIND (clause))
+ {
+ case GOMP_MAP_TO:
+ case GOMP_MAP_FROM:
+ case GOMP_MAP_TOFROM:
+ case GOMP_MAP_ALWAYS_TO:
+ case GOMP_MAP_ALWAYS_FROM:
+ case GOMP_MAP_ALWAYS_TOFROM:
+ case GOMP_MAP_ALWAYS_PRESENT_FROM:
+ case GOMP_MAP_ALWAYS_PRESENT_TO:
+ case GOMP_MAP_ALWAYS_PRESENT_TOFROM:
+ case GOMP_MAP_FIRSTPRIVATE:
+ case GOMP_MAP_ALLOC:
+ return true;
+ case GOMP_MAP_POINTER:
+ case GOMP_MAP_TO_PSET:
+ case GOMP_MAP_FORCE_PRESENT:
+ case GOMP_MAP_DELETE:
+ case GOMP_MAP_FORCE_DEVICEPTR:
+ case GOMP_MAP_DEVICE_RESIDENT:
+ case GOMP_MAP_LINK:
+ case GOMP_MAP_IF_PRESENT:
+ case GOMP_MAP_PRESENT_ALLOC:
+ case GOMP_MAP_PRESENT_FROM:
+ case GOMP_MAP_PRESENT_TO:
+ case GOMP_MAP_PRESENT_TOFROM:
+ case GOMP_MAP_FIRSTPRIVATE_INT:
+ case GOMP_MAP_USE_DEVICE_PTR:
+ case GOMP_MAP_ZERO_LEN_ARRAY_SECTION:
+ case GOMP_MAP_FORCE_ALLOC:
+ case GOMP_MAP_FORCE_TO:
+ case GOMP_MAP_FORCE_FROM:
+ case GOMP_MAP_FORCE_TOFROM:
+ case GOMP_MAP_USE_DEVICE_PTR_IF_PRESENT:
+ case GOMP_MAP_STRUCT:
+ case GOMP_MAP_STRUCT_UNORD:
+ case GOMP_MAP_ALWAYS_POINTER:
+ case GOMP_MAP_POINTER_TO_ZERO_LENGTH_ARRAY_SECTION:
+ case GOMP_MAP_DELETE_ZERO_LEN_ARRAY_SECTION:
+ case GOMP_MAP_RELEASE:
+ case GOMP_MAP_ATTACH:
+ case GOMP_MAP_DETACH:
+ case GOMP_MAP_FORCE_DETACH:
+ case GOMP_MAP_ATTACH_ZERO_LENGTH_ARRAY_SECTION:
+ case GOMP_MAP_FIRSTPRIVATE_POINTER:
+ case GOMP_MAP_FIRSTPRIVATE_REFERENCE:
+ case GOMP_MAP_ATTACH_DETACH:
+ break;
+ default:
+ gcc_unreachable ();
+ }
+ return false;
+}
+
+/* Three OpenMP deep-mapping lang hooks: gfc_omp_deep_mapping{_p,_cnt,}. */
+
+/* Common check for gfc_omp_deep_mapping_p and gfc_omp_deep_mapping_do. */
+
+static tree
+gfc_omp_deep_mapping_int_p (const gimple *ctx, tree clause)
+{
+ if (is_gimple_omp_oacc (ctx) || !gfc_omp_deep_map_kind_p (clause))
+ return NULL_TREE;
+ tree decl = OMP_CLAUSE_DECL (clause);
+ if (OMP_CLAUSE_SIZE (clause) != NULL_TREE
+ && DECL_P (OMP_CLAUSE_SIZE (clause))
+ && DECL_LANG_SPECIFIC (OMP_CLAUSE_SIZE (clause))
+ && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_SIZE (clause)))
+ /* Saved decl. */
+ decl = GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_SIZE (clause));
+ else if (TREE_CODE (decl) == MEM_REF || TREE_CODE (decl) == INDIRECT_REF)
+ /* The following can happen for, e.g., class(t) :: var(..) */
+ decl = TREE_OPERAND (decl, 0);
+ if (TREE_CODE (decl) == INDIRECT_REF)
+ /* The following can happen for, e.g., class(t) :: var(..) */
+ decl = TREE_OPERAND (decl, 0);
+ if (DECL_P (decl)
+ && DECL_LANG_SPECIFIC (decl)
+ && GFC_DECL_SAVED_DESCRIPTOR (decl))
+ decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
+ /* Handle map(to: var.desc) map([to/from/tofrom:] var.desc.data)
+ to get proper map kind by skipping to the next item. */
+ tree tmp = OMP_CLAUSE_CHAIN (clause);
+ if (tmp != NULL_TREE
+ && OMP_CLAUSE_CODE (tmp) == OMP_CLAUSE_CODE (clause)
+ && OMP_CLAUSE_SIZE (tmp) != NULL_TREE
+ && DECL_P (OMP_CLAUSE_SIZE (tmp))
+ && DECL_LANG_SPECIFIC (OMP_CLAUSE_SIZE (tmp))
+ && GFC_DECL_SAVED_DESCRIPTOR (OMP_CLAUSE_SIZE (tmp)) == decl)
+ return NULL_TREE;
+ if (DECL_P (decl)
+ && DECL_LANG_SPECIFIC (decl)
+ && GFC_DECL_SAVED_DESCRIPTOR (decl))
+ decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
+ tree type = TREE_TYPE (decl);
+ if (POINTER_TYPE_P (type))
+ type = TREE_TYPE (type);
+ if (POINTER_TYPE_P (type))
+ type = TREE_TYPE (type);
+ tmp = decl;
+ while (TREE_CODE (tmp) == COMPONENT_REF || TREE_CODE (tmp) == ARRAY_REF)
+ tmp = TREE_OPERAND (tmp, TREE_CODE (tmp) == COMPONENT_REF ? 1 : 0);
+ if (!gfc_is_polymorphic_nonptr (type)
+ && !gfc_has_alloc_comps (type, tmp, true))
+ return NULL_TREE;
+ return decl;
+}
+
+/* Return true if there is deep mapping, even if the number of mapping is known
+ at compile time. */
+bool
+gfc_omp_deep_mapping_p (const gimple *ctx, tree clause)
+{
+ tree decl = gfc_omp_deep_mapping_int_p (ctx, clause);
+ if (decl == NULL_TREE)
+ return false;
+ return true;
+}
+
+/* Handle gfc_omp_deep_mapping{,_cnt} */
+static tree
+gfc_omp_deep_mapping_do (bool is_cnt, const gimple *ctx, tree clause,
+ unsigned HOST_WIDE_INT tkind, tree data, tree sizes,
+ tree kinds, tree offset_data, tree offset,
+ gimple_seq *seq)
+{
+ tree num = NULL_TREE;
+ location_t loc = OMP_CLAUSE_LOCATION (clause);
+ tree decl = gfc_omp_deep_mapping_int_p (ctx, clause);
+ bool poly_warned = false;
+ if (decl == NULL_TREE)
+ return NULL_TREE;
+ /* Handle: map(alloc:dt%cmp [len: ptr_size]) map(tofrom: D.0123...),
+ where GFC_DECL_SAVED_DESCRIPTOR(D.0123) is the same (here: dt%cmp). */
+ if (OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_MAP
+ && (OMP_CLAUSE_MAP_KIND (clause) == GOMP_MAP_ALLOC
+ || OMP_CLAUSE_MAP_KIND (clause) == GOMP_MAP_PRESENT_ALLOC))
+ {
+ tree c = clause;
+ while ((c = OMP_CLAUSE_CHAIN (c)) != NULL_TREE)
+ {
+ if (!gfc_omp_deep_map_kind_p (c))
+ continue;
+ tree d = gfc_omp_deep_mapping_int_p (ctx, c);
+ if (d != NULL_TREE && operand_equal_p (decl, d, 0))
+ return NULL_TREE;
+ }
+ }
+ tree type = TREE_TYPE (decl);
+ if (POINTER_TYPE_P (type))
+ type = TREE_TYPE (type);
+ if (POINTER_TYPE_P (type))
+ type = TREE_TYPE (type);
+ bool poly = gfc_is_polymorphic_nonptr (type);
+
+ if (is_cnt)
+ {
+ num = build_decl (loc, VAR_DECL,
+ create_tmp_var_name ("n_deepmap"), size_type_node);
+ tree tmp = fold_build2_loc (loc, MODIFY_EXPR, size_type_node, num,
+ build_int_cst (size_type_node, 0));
+ gimple_add_tmp_var (num);
+ gimplify_and_add (tmp, seq);
+ }
+ else
+ gcc_assert (short_unsigned_type_node == TREE_TYPE (TREE_TYPE (kinds)));
+
+ bool do_copy = poly;
+ bool do_alloc_check = false;
+ tree token = NULL_TREE;
+ tree tmp = decl;
+ if (poly)
+ {
+ tmp = TYPE_FIELDS (type);
+ type = TREE_TYPE (tmp);
+ }
+ else
+ while (TREE_CODE (tmp) == COMPONENT_REF || TREE_CODE (tmp) == ARRAY_REF)
+ tmp = TREE_OPERAND (tmp, TREE_CODE (tmp) == COMPONENT_REF ? 1 : 0);
+ /* If the clause argument is nonallocatable, skip is-allocate check. */
+ if (GFC_DECL_GET_SCALAR_ALLOCATABLE (tmp)
+ || GFC_DECL_GET_SCALAR_POINTER (tmp)
+ || (GFC_DESCRIPTOR_TYPE_P (type)
+ && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)))
+ do_alloc_check = true;
+
+ if (!is_cnt
+ && OMP_CLAUSE_CODE (clause) == OMP_CLAUSE_MAP
+ && (tkind == GOMP_MAP_ALLOC
+ || (tkind == GOMP_MAP_FROM
+ && (gimple_omp_target_kind (ctx)
+ != GF_OMP_TARGET_KIND_EXIT_DATA)))
+ && (poly || gfc_omp_replace_alloc_by_to_mapping (type, tmp, true)))
+ OMP_CLAUSE_SET_MAP_KIND (clause, tkind == GOMP_MAP_ALLOC ? GOMP_MAP_TO
+ : GOMP_MAP_TOFROM);
+
+ /* TODO: For map(a(:)), we know it is present & allocated. */
+
+ tree present = (DECL_P (decl) ? gfc_omp_check_optional_argument (decl, true)
+ : NULL_TREE);
+ if (POINTER_TYPE_P (TREE_TYPE (decl))
+ && POINTER_TYPE_P (TREE_TYPE (TREE_TYPE (decl))))
+ decl = build_fold_indirect_ref (decl);
+ if (present)
+ {
+ tree then_label = create_artificial_label (loc);
+ tree end_label = create_artificial_label (loc);
+ gimple_seq seq2 = NULL;
+ tmp = force_gimple_operand (present, &seq2, true, NULL_TREE);
+ gimple_seq_add_seq (seq, seq2);
+ gimple_seq_add_stmt (seq,
+ gimple_build_cond_from_tree (present,
+ then_label, end_label));
+ gimple_seq_add_stmt (seq, gimple_build_label (then_label));
+ gfc_omp_deep_mapping_item (is_cnt, do_copy, do_alloc_check, loc, decl,
+ &token, tkind, data, sizes, kinds,
+ offset_data, offset, num, seq, ctx,
+ &poly_warned);
+ gimple_seq_add_stmt (seq, gimple_build_label (end_label));
+ }
+ else
+ gfc_omp_deep_mapping_item (is_cnt, do_copy, do_alloc_check, loc, decl,
+ &token, tkind, data, sizes, kinds, offset_data,
+ offset, num, seq, ctx, &poly_warned);
+ /* Multiply by 2 as there are two mappings: data + pointer assign. */
+ if (is_cnt)
+ gimplify_assign (num,
+ fold_build2_loc (loc, MULT_EXPR,
+ size_type_node, num,
+ build_int_cst (size_type_node, 2)), seq);
+ return num;
+}
+
+/* Return tree with a variable which contains the count of deep-mappyings
+ (value depends, e.g., on allocation status) */
+tree
+gfc_omp_deep_mapping_cnt (const gimple *ctx, tree clause, gimple_seq *seq)
+{
+ return gfc_omp_deep_mapping_do (true, ctx, clause, 0, NULL_TREE, NULL_TREE,
+ NULL_TREE, NULL_TREE, NULL_TREE, seq);
+}
+
+/* Does the actual deep mapping. */
+void
+gfc_omp_deep_mapping (const gimple *ctx, tree clause,
+ unsigned HOST_WIDE_INT tkind, tree data,
+ tree sizes, tree kinds, tree offset_data, tree offset,
+ gimple_seq *seq)
+{
+ (void) gfc_omp_deep_mapping_do (false, ctx, clause, tkind, data, sizes, kinds,
+ offset_data, offset, seq);
+}
+
/* Return true if DECL is a scalar variable (for the purpose of
implicit firstprivatization/mapping). Only if 'ptr_alloc_ok.'
is true, allocatables and pointers are permitted. */
@@ -2478,6 +3265,18 @@ gfc_trans_omp_array_section (stmtblock_t *block, gfc_exec_op op,
elemsz = fold_convert (gfc_array_index_type, elemsz);
OMP_CLAUSE_SIZE (node) = fold_build2 (MULT_EXPR, gfc_array_index_type,
OMP_CLAUSE_SIZE (node), elemsz);
+ if (n->expr->ts.type == BT_DERIVED
+ && n->expr->ts.u.derived->attr.alloc_comp)
+ {
+ /* Save array descriptor for use in gfc_omp_deep_mapping{,_p,_cnt};
+ force evaluate to ensure that it is not gimplified + is a decl. */
+ tree tmp = OMP_CLAUSE_SIZE (node);
+ tree var = gfc_create_var (TREE_TYPE (tmp), NULL);
+ gfc_add_modify_loc (input_location, block, var, tmp);
+ OMP_CLAUSE_SIZE (node) = var;
+ gfc_allocate_lang_decl (var);
+ GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr;
+ }
}
gcc_assert (se.post.head == NULL_TREE);
gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
@@ -3213,8 +4012,9 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
if (!n->sym->attr.referenced)
continue;
+ location_t map_loc = gfc_get_location (&n->where);
bool always_modifier = false;
- tree node = build_omp_clause (input_location, OMP_CLAUSE_MAP);
+ tree node = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
tree node2 = NULL_TREE;
tree node3 = NULL_TREE;
tree node4 = NULL_TREE;
@@ -3361,7 +4161,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
&& n->u.map.op != OMP_MAP_RELEASE)
{
gcc_assert (n->sym->ts.u.cl->backend_decl);
- node5 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
+ node5 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (node5, GOMP_MAP_ALWAYS_TO);
OMP_CLAUSE_DECL (node5) = n->sym->ts.u.cl->backend_decl;
OMP_CLAUSE_SIZE (node5)
@@ -3378,7 +4178,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
ptr = build_fold_indirect_ref (ptr);
OMP_CLAUSE_DECL (node) = ptr;
OMP_CLAUSE_SIZE (node) = gfc_class_vtab_size_get (decl);
- node2 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
+ node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_ATTACH_DETACH);
OMP_CLAUSE_DECL (node2) = gfc_class_data_get (decl);
OMP_CLAUSE_SIZE (node2) = size_int (0);
@@ -3434,8 +4234,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
size = TYPE_SIZE_UNIT (TREE_TYPE (decl));
else
size = size_int (0);
- node4 = build_omp_clause (input_location,
- OMP_CLAUSE_MAP);
+ node4 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (node4, gmk);
OMP_CLAUSE_DECL (node4) = decl;
OMP_CLAUSE_SIZE (node4) = size;
@@ -3459,8 +4258,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
size = TYPE_SIZE_UNIT (TREE_TYPE (decl));
else
size = size_int (0);
- node3 = build_omp_clause (input_location,
- OMP_CLAUSE_MAP);
+ node3 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (node3, gmk);
OMP_CLAUSE_DECL (node3) = decl;
OMP_CLAUSE_SIZE (node3) = size;
@@ -3477,7 +4275,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
gcc_assert (POINTER_TYPE_P (TREE_TYPE (ptr)));
ptr = build_fold_indirect_ref (ptr);
OMP_CLAUSE_DECL (node) = ptr;
- node2 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
+ node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
OMP_CLAUSE_DECL (node2) = decl;
OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
if (n->u.map.op == OMP_MAP_DELETE)
@@ -3493,8 +4291,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
&& n->u.map.op != OMP_MAP_DELETE
&& n->u.map.op != OMP_MAP_RELEASE)
{
- node3 = build_omp_clause (input_location,
- OMP_CLAUSE_MAP);
+ node3 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
if (present)
{
ptr = gfc_conv_descriptor_data_get (decl);
@@ -3634,10 +4431,10 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
{
/* A single indirectref is handled by the middle end. */
gcc_assert (!POINTER_TYPE_P (TREE_TYPE (decl)));
- decl = TREE_OPERAND (decl, 0);
- decl = gfc_build_cond_assign_expr (block, present, decl,
+ tree tmp = TREE_OPERAND (decl, 0);
+ tmp = gfc_build_cond_assign_expr (block, present, tmp,
null_pointer_node);
- OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (decl);
+ OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (tmp);
}
else
OMP_CLAUSE_DECL (node) = decl;
@@ -3672,6 +4469,33 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
size = gfc_evaluate_now (size, block);
OMP_CLAUSE_SIZE (node) = size;
}
+ if ((TREE_CODE (decl) != PARM_DECL
+ || DECL_ARTIFICIAL (OMP_CLAUSE_DECL (node)))
+ && n->sym->ts.type == BT_DERIVED
+ && n->sym->ts.u.derived->attr.alloc_comp)
+ {
+ /* Save array descriptor for use in
+ gfc_omp_deep_mapping{,_p,_cnt}; force evaluate
+ to ensure that it is not gimplified + is a decl. */
+ tree tmp = OMP_CLAUSE_SIZE (node);
+ if (tmp == NULL_TREE)
+ tmp = DECL_P (decl) ? DECL_SIZE_UNIT (decl)
+ : TYPE_SIZE_UNIT (TREE_TYPE (decl));
+ tree var = gfc_create_var (TREE_TYPE (tmp), NULL);
+ gfc_add_modify_loc (input_location, block, var, tmp);
+ OMP_CLAUSE_SIZE (node) = var;
+ gfc_allocate_lang_decl (var);
+ if (TREE_CODE (decl) == INDIRECT_REF)
+ decl = TREE_OPERAND (decl, 0);
+ if (TREE_CODE (decl) == INDIRECT_REF)
+ decl = TREE_OPERAND (decl, 0);
+ if (DECL_LANG_SPECIFIC (decl)
+ && GFC_DECL_SAVED_DESCRIPTOR (decl))
+ GFC_DECL_SAVED_DESCRIPTOR (var)
+ = GFC_DECL_SAVED_DESCRIPTOR (decl);
+ else
+ GFC_DECL_SAVED_DESCRIPTOR (var) = decl;
+ }
}
else if (n->expr
&& n->expr->expr_type == EXPR_VARIABLE
@@ -3727,8 +4551,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
goto finalize_map_clause;
}
- node2 = build_omp_clause (input_location,
- OMP_CLAUSE_MAP);
+ node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (node2, GOMP_MAP_ATTACH_DETACH);
OMP_CLAUSE_DECL (node2)
= POINTER_TYPE_P (TREE_TYPE (se.expr))
@@ -3754,13 +4577,37 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
kind = GOMP_MAP_RELEASE;
else
kind = GOMP_MAP_TO;
- node3 = build_omp_clause (input_location,
- OMP_CLAUSE_MAP);
+ node3 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (node3, kind);
OMP_CLAUSE_DECL (node3) = se.string_length;
OMP_CLAUSE_SIZE (node3)
= TYPE_SIZE_UNIT (gfc_charlen_type_node);
}
+ if (!openacc
+ && n->expr->ts.type == BT_DERIVED
+ && n->expr->ts.u.derived->attr.alloc_comp)
+ {
+ /* Save array descriptor for use in
+ gfc_omp_deep_mapping{,_p,_cnt}; force evaluate
+ to ensure that it is not gimplified + is a decl. */
+ tree tmp = OMP_CLAUSE_SIZE (node);
+ if (tmp == NULL_TREE)
+ tmp = (DECL_P (se.expr)
+ ? DECL_SIZE_UNIT (se.expr)
+ : TYPE_SIZE_UNIT (TREE_TYPE (se.expr)));
+ tree var = gfc_create_var (TREE_TYPE (tmp), NULL);
+ gfc_add_modify_loc (input_location, block, var, tmp);
+ OMP_CLAUSE_SIZE (node) = var;
+ gfc_allocate_lang_decl (var);
+ if (TREE_CODE (se.expr) == INDIRECT_REF)
+ se.expr = TREE_OPERAND (se.expr, 0);
+ if (DECL_LANG_SPECIFIC (se.expr)
+ && GFC_DECL_SAVED_DESCRIPTOR (se.expr))
+ GFC_DECL_SAVED_DESCRIPTOR (var)
+ = GFC_DECL_SAVED_DESCRIPTOR (se.expr);
+ else
+ GFC_DECL_SAVED_DESCRIPTOR (var) = se.expr;
+ }
}
}
else if (n->expr
@@ -3800,7 +4647,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
&& (lastref->u.c.component->ts.type == BT_DERIVED
|| lastref->u.c.component->ts.type == BT_CLASS))
{
- if (pointer || (openacc && allocatable))
+ if (pointer || allocatable)
{
/* If it's a bare attach/detach clause, we just want
to perform a single attach/detach operation, of the
@@ -3880,8 +4727,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
OMP_CLAUSE_DECL (node) = data;
OMP_CLAUSE_SIZE (node) = size;
- node2 = build_omp_clause (input_location,
- OMP_CLAUSE_MAP);
+ node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (node2,
GOMP_MAP_ATTACH_DETACH);
OMP_CLAUSE_DECL (node2) = build_fold_addr_expr (data);
@@ -3893,6 +4739,22 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
OMP_CLAUSE_SIZE (node)
= TYPE_SIZE_UNIT (TREE_TYPE (inner));
}
+ if (!openacc
+ && n->expr->ts.type == BT_DERIVED
+ && n->expr->ts.u.derived->attr.alloc_comp)
+ {
+ /* Save array descriptor for use in
+ gfc_omp_deep_mapping{,_p,_cnt}; force evaluate
+ to ensure that it is not gimplified + is a decl. */
+ tree tmp = OMP_CLAUSE_SIZE (node);
+ tree var = gfc_create_var (TREE_TYPE (tmp), NULL);
+ gfc_add_modify_loc (input_location, block, var, tmp);
+ OMP_CLAUSE_SIZE (node) = var;
+ gfc_allocate_lang_decl (var);
+ if (TREE_CODE (inner) == INDIRECT_REF)
+ inner = TREE_OPERAND (inner, 0);
+ GFC_DECL_SAVED_DESCRIPTOR (var) = inner;
+ }
}
else if (lastref->type == REF_ARRAY
&& lastref->u.ar.type == AR_FULL)
@@ -3952,8 +4814,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
elemsz = TYPE_SIZE_UNIT (elemsz);
elemsz = fold_build2 (MULT_EXPR, size_type_node,
len, elemsz);
- node4 = build_omp_clause (input_location,
- OMP_CLAUSE_MAP);
+ node4 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (node4, map_kind);
OMP_CLAUSE_DECL (node4) = se.string_length;
OMP_CLAUSE_SIZE (node4)
@@ -3963,8 +4824,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
OMP_CLAUSE_SIZE (node)
= fold_build2 (MULT_EXPR, gfc_array_index_type,
OMP_CLAUSE_SIZE (node), elemsz);
- node2 = build_omp_clause (input_location,
- OMP_CLAUSE_MAP);
+ node2 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
if (map_kind == GOMP_MAP_RELEASE
|| map_kind == GOMP_MAP_DELETE)
{
@@ -3978,6 +4838,23 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
OMP_CLAUSE_SIZE (node2) = TYPE_SIZE_UNIT (type);
if (!openacc)
{
+ if (n->expr->ts.type == BT_DERIVED
+ && n->expr->ts.u.derived->attr.alloc_comp)
+ {
+ /* Save array descriptor for use
+ in gfc_omp_deep_mapping{,_p,_cnt}; force
+ evaluate to ensure that it is
+ not gimplified + is a decl. */
+ tree tmp = OMP_CLAUSE_SIZE (node);
+ tree var = gfc_create_var (TREE_TYPE (tmp),
+ NULL);
+ gfc_add_modify_loc (map_loc, block,
+ var, tmp);
+ OMP_CLAUSE_SIZE (node) = var;
+ gfc_allocate_lang_decl (var);
+ GFC_DECL_SAVED_DESCRIPTOR (var) = inner;
+ }
+
gfc_omp_namelist *n2
= clauses->lists[OMP_LIST_MAP];
@@ -4035,8 +4912,7 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
if (drop_mapping)
continue;
}
- node3 = build_omp_clause (input_location,
- OMP_CLAUSE_MAP);
+ node3 = build_omp_clause (map_loc, OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (node3,
GOMP_MAP_ATTACH_DETACH);
OMP_CLAUSE_DECL (node3)
@@ -4107,7 +4983,8 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
default:
gcc_unreachable ();
}
- tree node = build_omp_clause (input_location, clause_code);
+ tree node = build_omp_clause (gfc_get_location (&n->where),
+ clause_code);
if (n->expr == NULL
|| (n->expr->ref->type == REF_ARRAY
&& n->expr->ref->u.ar.type == AR_FULL
diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc
index f16e1e3..37f8aca 100644
--- a/gcc/fortran/trans-stmt.cc
+++ b/gcc/fortran/trans-stmt.cc
@@ -19,7 +19,7 @@ You should have received a copy of the GNU General Public License
along with GCC; see the file COPYING3. If not see
<http://www.gnu.org/licenses/>. */
-
+#define INCLUDE_VECTOR
#include "config.h"
#include "system.h"
#include "coretypes.h"
@@ -5093,6 +5093,138 @@ gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
}
}
+/* For saving the outer-variable data when doing
+ LOCAL and LOCAL_INIT substitution. */
+struct symbol_and_tree_t
+{
+ gfc_symbol *sym;
+ gfc_expr *value;
+ tree decl;
+ symbol_attribute attr;
+};
+
+/* Handle the LOCAL and LOCAL_INIT locality specifiers. This has to be
+ called twice, once with after_body=false - and then after the loop
+ body has been processed with after_body=true.
+
+ Creates a copy of the variables that appear in the LOCAL and LOCAL_INIT
+ locality specifiers of 'do concurrent' - and use it in the original
+ gfc_symbol. The declaration is then reset by after_body=true.
+
+ Variables in LOCAL_INIT are set in every loop iteration. */
+
+void
+gfc_trans_concurrent_locality_spec (bool after_body, stmtblock_t *body,
+ std::vector<symbol_and_tree_t> *saved_decls,
+ gfc_expr_list **locality_list)
+{
+ if (!locality_list[LOCALITY_LOCAL] && !locality_list[LOCALITY_LOCAL_INIT])
+ return;
+
+ if (after_body)
+ {
+ for (unsigned i = 0; i < saved_decls->size (); i++)
+ {
+ (*saved_decls)[i].sym->backend_decl = (*saved_decls)[i].decl;
+ (*saved_decls)[i].sym->attr = (*saved_decls)[i].attr;
+ (*saved_decls)[i].sym->value = (*saved_decls)[i].value;
+ }
+ return;
+ }
+
+ gfc_expr_list *el;
+ int cnt = 0;
+ for (int i = 0; i <= 1; i++)
+ for (el = locality_list[i == 0 ? LOCALITY_LOCAL : LOCALITY_LOCAL_INIT];
+ el; el = el->next)
+ {
+ gfc_symbol *outer_sym = el->expr->symtree->n.sym;
+ if (!outer_sym->backend_decl)
+ outer_sym->backend_decl = gfc_get_symbol_decl (outer_sym);
+ cnt++;
+ }
+ saved_decls->resize (cnt);
+
+ /* The variables have to be created in the scope of the loop body. */
+ if (!body->has_scope)
+ {
+ gcc_checking_assert (body->head == NULL_TREE);
+ gfc_start_block (body);
+ }
+ gfc_start_saved_local_decls ();
+
+ cnt = 0;
+ static_assert (LOCALITY_LOCAL_INIT - LOCALITY_LOCAL == 1, "locality_type");
+ for (int type = LOCALITY_LOCAL;
+ type <= LOCALITY_LOCAL_INIT; type++)
+ for (el = locality_list[type]; el; el = el->next)
+ {
+ gfc_symbol *sym = el->expr->symtree->n.sym;
+ (*saved_decls)[cnt].sym = sym;
+ (*saved_decls)[cnt].attr = sym->attr;
+ (*saved_decls)[cnt].value = sym->value;
+ (*saved_decls)[cnt].decl = sym->backend_decl;
+
+ if (sym->attr.dimension && sym->as->type == AS_ASSUMED_SHAPE)
+ {
+ gfc_error ("Sorry, %s specifier at %L for assumed-size array %qs "
+ "is not yet supported",
+ type == LOCALITY_LOCAL ? "LOCAL" : "LOCAL_INIT",
+ &el->expr->where, sym->name);
+ continue;
+ }
+
+ gfc_symbol outer_sym = *sym;
+
+ /* Create the inner local variable. */
+ sym->backend_decl = NULL;
+ sym->value = NULL;
+ sym->attr.save = SAVE_NONE;
+ sym->attr.value = 0;
+ sym->attr.dummy = 0;
+ sym->attr.optional = 0;
+
+ {
+ /* Slightly ugly hack for adding the decl via add_decl_as_local. */
+ gfc_symbol dummy_block_sym;
+ dummy_block_sym.attr.flavor = FL_LABEL;
+ gfc_symbol *saved_proc_name = sym->ns->proc_name;
+ sym->ns->proc_name = &dummy_block_sym;
+
+ gfc_get_symbol_decl (sym);
+ DECL_SOURCE_LOCATION (sym->backend_decl)
+ = gfc_get_location (&el->expr->where);
+
+ sym->ns->proc_name = saved_proc_name;
+ }
+
+ symbol_attribute attr = gfc_expr_attr (el->expr);
+ if (type == LOCALITY_LOCAL
+ && !attr.pointer
+ && sym->ts.type == BT_DERIVED
+ && gfc_has_default_initializer (sym->ts.u.derived))
+ /* Cf. PR fortran/ */
+ gfc_error ("Sorry, LOCAL specifier at %L for %qs of derived type with"
+ " default initializer is not yet supported",
+ &el->expr->where, sym->name);
+ if (type == LOCALITY_LOCAL_INIT)
+ {
+ /* LOCAL_INIT: local_var = outer_var. */
+ gfc_symtree st = *el->expr->symtree;
+ st.n.sym = &outer_sym;
+ gfc_expr expr = *el->expr;
+ expr.symtree = &st;
+ tree t = (attr.pointer
+ ? gfc_trans_pointer_assignment (el->expr, &expr)
+ : gfc_trans_assignment (el->expr, &expr, false, false,
+ false, false));
+ gfc_add_expr_to_block (body, t);
+ }
+ cnt++;
+ }
+ gfc_stop_saved_local_decls ();
+}
+
/* FORALL and WHERE statements are really nasty, especially when you nest
them. All the rhs of a forall assignment must be evaluated before the
@@ -5348,9 +5480,19 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
gfc_init_block (&body);
cycle_label = gfc_build_label_decl (NULL_TREE);
code->cycle_label = cycle_label;
+
+ /* Handle LOCAL and LOCAL_INIT. */
+ std::vector<symbol_and_tree_t> saved_decls;
+ gfc_trans_concurrent_locality_spec (false, &body, &saved_decls,
+ code->ext.concur.locality);
+
+ /* Translate the body. */
tmp = gfc_trans_code (code->block->next);
gfc_add_expr_to_block (&body, tmp);
+ /* Reset locality variables. */
+ gfc_trans_concurrent_locality_spec (true, &body, &saved_decls,
+ code->ext.concur.locality);
if (TREE_USED (cycle_label))
{
tmp = build1_v (LABEL_EXPR, cycle_label);
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 69c3d90..ae7be9f 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -804,6 +804,8 @@ tree gfc_build_library_function_decl_with_spec (tree name, const char *spec,
tree rettype, int nargs, ...);
/* Process the local variable decls of a block construct. */
+void gfc_start_saved_local_decls ();
+void gfc_stop_saved_local_decls ();
void gfc_process_block_locals (gfc_namespace*);
/* Output initialization/clean-up code that was deferred. */
@@ -837,6 +839,10 @@ tree gfc_omp_clause_assign_op (tree, tree, tree);
tree gfc_omp_clause_linear_ctor (tree, tree, tree, tree);
tree gfc_omp_clause_dtor (tree, tree);
void gfc_omp_finish_clause (tree, gimple_seq *, bool);
+bool gfc_omp_deep_mapping_p (const gimple *, tree);
+tree gfc_omp_deep_mapping_cnt (const gimple *, tree, gimple_seq *);
+void gfc_omp_deep_mapping (const gimple *, tree, unsigned HOST_WIDE_INT, tree,
+ tree, tree, tree, tree, gimple_seq *);
bool gfc_omp_allocatable_p (tree);
bool gfc_omp_scalar_p (tree, bool);
bool gfc_omp_scalar_target_p (tree);
generated by cgit v1.1 at 2025-04-22 08:47:38 +0000