Fortran/OpenMP: Support mapping of DT with allocatable components
gcc/fortran/ChangeLog:
* class.cc (finalization_scalarizer): Mark syms as artificial.
(generate_callback_wrapper): New.
(gfc_find_derived_vtab): Call it, add _callback comp.
* f95-lang.cc (LANG_HOOKS_OMP_DEEP_MAPPING,
LANG_HOOKS_OMP_DEEP_MAPPING_P,
LANG_HOOKS_OMP_DEEP_MAPPING_CNT): Redeinfe
* gfortran.h (gfc_import_iso_c_binding_module,
GFC_CLASS_CALLBACK_DEFAULT_FLAG, GFC_CLASS_CALLBACK_VTABLE_FLAG,
GFC_CLASS_CB_ALLOCATABLE, GFC_CLASS_CB_POINTER,
GFC_CLASS_CB_PROC_POINTER, GFC_CLASS_CB_VTABLE,
GFC_CLASS_CB_VPTR): New.
* match.cc (select_type_set_tmp): Propagate allocatable property.
* module.cc (MOD_VERSION): Bump due to vtab change.
(import_iso_c_binding_module): New import_all arg.
(gfc_import_iso_c_binding_module): New.
(gfc_use_module): Update call.
* openmp.cc (resolve_omp_clauses): Accept DT with alloc comps.
* resolve.cc (gfc_resolve_formal_arglist, gfc_resolve_intrinsic,
resolve_fl_procedure, resolve_types): Permit some violations
for internal code.
* trans-array.cc (gfc_conv_descriptor_stride_get,
gfc_tree_array_size, gfc_full_array_size): Update
for GFC_TYPE_ARRAY_AKIND change.
(gfc_conv_expr_descriptor): Likewise; permit calling with tree code.
* trans-expr.cc (VTABLE_CALLBACK_FIELD): Add.
(VTAB_GET_FIELD_GEN): Use it.
(VTABLE_DEALLOCATE_FIELD): Undef at the end.
(gfc_conv_expr_reference): Fixes; avoid unneccessary temp var.
* trans-intrinsic.cc (gfc_conv_intrinsic_sizeof,
gfc_conv_associated): Fix class and comp-ref handling.
(conv_isocbinding_function): Remove buggy code.
* trans-openmp.cc (gfc_has_alloc_comps): Add ptr_ok arg.
(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,
(gfc_omp_finish_clause): Update call.
(GFC_MAP_TOKEN_DATA, GFC_MAP_TOKEN_SIZES, GFC_MAP_TOKEN_KINDS,
GFC_MAP_TOKEN_DATA_OFFSET, GFC_MAP_TOKEN_OFFSET,
GFC_MAP_TOKEN_FLAGS, GFC_MAP_TOKEN_DETACH): Define.
(gfc_omp_get_token_data, gfc_omp_get_token_sizes,
gfc_omp_get_token_kinds, gfc_omp_get_token_offset_data,
gfc_omp_get_token_offset, gfc_omp_get_token_flags,
gfc_omp_get_token_detach, gfc_omp_get_map_token_type,
gfc_omp_get_cb_type, gfc_omp_gen_deep_map_fn,
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 clause decl to survive gimplifying.
(gfc_trans_omp_clauses): Likewise; fixes.
* trans-types.cc (gfc_build_array_type, gfc_get_derived_type,
gfc_get_array_descr_info): Update array kind to distinguish
different assumed-rank arrays.
* trans.h (gfc_class_vtab_callback_get, gfc_omp_deep_mapping_p,
gfc_omp_deep_mapping_cnt, gfc_omp_deep_mapping): New prototypes.
(enum gfc_array_kind): Additional GFC_ARRAY_ASSUMED_RANK_* entries.
gcc/ChangeLog:
* langhooks-def.h (lhd_omp_deep_mapping_p,
lhd_omp_deep_mapping_cnt, lhd_omp_deep_mapping): New.
(LANG_HOOKS_OMP_DEEP_MAPPING_P, LANG_HOOKS_OMP_DEEP_MAPPING_CNT,
LANG_HOOKS_OMP_DEEP_MAPPING): Define.
(LANG_HOOKS_DECLS): Use it.
* langhooks.cc (lhd_omp_deep_mapping_p, lhd_omp_deep_mapping_cnt,
lhd_omp_deep_mapping): New stubs.
* langhooks.h (struct lang_hooks_for_decls): Add new hooks
* omp-expand.cc (expand_omp_target): Handle dynamic-size
addr/sizes/kinds arrays.
* omp-low.cc (build_sender_ref, fixup_child_record_type,
scan_sharing_clauses, lower_omp_target): Update to handle
new hooks and dynamic-size addr/sizes/kinds arrays.
libgomp/ChangeLog:
* testsuite/libgomp.oacc-fortran/host_data-5.F90: Update dg-note.
* testsuite/libgomp.fortran/allocatable-comp.f90: New test.
* testsuite/libgomp.fortran/map-alloc-comp-3.f90: New test.
* testsuite/libgomp.fortran/map-alloc-comp-4.f90: New test.
* testsuite/libgomp.fortran/map-alloc-comp-5.f90: New test.
* testsuite/libgomp.fortran/map-alloc-comp-6.f90: New test.
* testsuite/libgomp.fortran/map-alloc-comp-7.f90: New test.
gcc/testsuite/ChangeLog:
* gfortran.dg/c_loc_test_22.f90: Update scan-tree.
* gfortran.dg/finalize_21.f90: Likewise.
* gfortran.dg/goacc/array-with-dt-1.f90: Remove dg-warning.
* gfortran.dg/goacc/pr93464.f90: Remove dg-warning.
* gfortran.dg/gomp/map-alloc-comp-1.f90: Remove sorry dg-error.
gcc/fortran/class.cc | 523 ++++++-
gcc/fortran/f95-lang.cc | 6 +
gcc/fortran/gfortran.h | 8 +
gcc/fortran/match.cc | 2 +
gcc/fortran/module.cc | 28 +-
gcc/fortran/openmp.cc | 7 -
gcc/fortran/resolve.cc | 11 +-
gcc/fortran/trans-array.cc | 48 +-
gcc/fortran/trans-expr.cc | 11 +-
gcc/fortran/trans-intrinsic.cc | 33 +-
gcc/fortran/trans-openmp.cc | 1521 +++++++++++++++++++-
gcc/fortran/trans-types.cc | 50 +-
gcc/fortran/trans.h | 8 +
gcc/langhooks-def.h | 10 +
gcc/langhooks.cc | 24 +
gcc/langhooks.h | 15 +
gcc/omp-expand.cc | 18 +-
gcc/omp-low.cc | 224 ++-
gcc/testsuite/gfortran.dg/c_loc_test_22.f90 | 2 +-
gcc/testsuite/gfortran.dg/finalize_21.f90 | 2 +-
.../gfortran.dg/goacc/array-with-dt-1.f90 | 3 -
gcc/testsuite/gfortran.dg/goacc/pr93464.f90 | 3 -
.../gfortran.dg/gomp/map-alloc-comp-1.f90 | 2 +-
.../testsuite/libgomp.fortran/allocatable-comp.f90 | 53 +
.../testsuite/libgomp.fortran/map-alloc-comp-3.f90 | 121 ++
.../testsuite/libgomp.fortran/map-alloc-comp-4.f90 | 124 ++
.../testsuite/libgomp.fortran/map-alloc-comp-5.f90 | 53 +
.../testsuite/libgomp.fortran/map-alloc-comp-6.f90 | 308 ++++
.../testsuite/libgomp.fortran/map-alloc-comp-7.f90 | 672 +++++++++
.../testsuite/libgomp.oacc-fortran/host_data-5.F90 | 4 +
30 files changed, 3745 insertions(+), 149 deletions(-)
@@ -51,6 +51,8 @@ along with GCC; see the file COPYING3. If not see
allocatable components and calls FINAL subroutines.
* _deallocate: A procedure pointer to a deallocation procedure; nonnull
only for a recursive derived type.
+ * _callback: A procedure pointer, taking a callback proc pointer and
+ calling that one for the DT and the allocatable components.
After these follow procedure pointer components for the specific
type-bound procedures. */
@@ -1115,6 +1117,7 @@ finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr,
/* C_F_POINTER(). */
block = gfc_get_code (EXEC_CALL);
gfc_get_sym_tree ("c_f_pointer", sub_ns, &block->symtree, true);
+ block->symtree->n.sym->attr.artificial = 1;
block->resolved_sym = block->symtree->n.sym;
block->resolved_sym->attr.flavor = FL_PROCEDURE;
block->resolved_sym->attr.intrinsic = 1;
@@ -1137,6 +1140,7 @@ finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr,
expr = gfc_get_expr ();
expr->expr_type = EXPR_FUNCTION;
gfc_get_sym_tree ("c_loc", sub_ns, &expr->symtree, false);
+ expr->symtree->n.sym->attr.artificial = 1;
expr->symtree->n.sym->attr.flavor = FL_PROCEDURE;
expr->symtree->n.sym->intmod_sym_id = ISOCBINDING_LOC;
expr->symtree->n.sym->attr.intrinsic = 1;
@@ -2241,6 +2245,509 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns,
free (name);
}
+/* Generate: __callback (cb, token, this)
+ with size_t (*cb) (cb_token, cb_addr, cb_len, cb_flag, cb_fn)
+ void *token
+ void *this_ptr - flag=GFC_CLASS_CALLBACK_VTABLE_FLAG:
+ scalar pointer to this DT -> 'scalar'
+ flag flag=GFC_CLASS_CALLBACK_DEFAULT_FLAG:
+ var's _vtab component
+ Assumed to be != NULL.
+ flag - GFC_CLASS_CALLBACK_DEFAULT_FLAG:
+ map allocatable/pointer components
+ GFC_CLASS_CALLBACK_VTABLE_FLAG:
+ map vtable of this type and return
+ cb_flag: GFC_CLASS_CB_ALLOCATABLE, GFC_CLASS_CB_POINTER,
+ GFC_CLASS_CB_VTABLE, GFC_CLASS_CB_VPTR
+ Calls 'cb' with:
+ cb_token := token
+ if flag == GFC_CLASS_CALLBACK_VTABLE_FLAG:
+ cb_var := this_ptr; size = c_sizeof (vtable); cb_flag=GFC_CLASS_CB_VTABLE
+ else (flag = GFC_CLASS_CALLBACK_DEFAULT_FLAG)
+ call c_f_pointer (this_ptr, scalar)
+ for each component:
+ if pointer && associated
+ [class only] cb_var = scalar.comp._vptr, size == 0,
+ cb_flag = GFC_CLASS_CB_VPTR
+ cb_var = scalar.comp.(_data), size == 0, cb_flag=GFC_CLASS_CB_POINTER
+ if allocatable && allocatated
+ [class only]
+ scalar.comp._vptr->callback(cb, token, scalar.comp._vptr,
+ flag=GFC_CLASS_CALLBACK_VTABLE_FLAG)
+ cb_var = scalar.comp._vptr, size == c_sizeof(scalar.comp.(_data),
+ cb_flag = GFC_CLASS_CB_ALLOCATABLE
+ if (allocatable comp || class)
+ [class only]
+ scalar.comp._vptr->callback(cb, token, scalar.comp._vptr,
+ flag=GFC_CLASS_CALLBACK_VTABLE_FLAG)
+ // Note: callback is elemental, i.e. one call per array elem
+ scalar.comp._vptr->callback(cb, token, scalar.comp.(_data),
+ flag=GFC_CLASS_CALLBACK_DEFAULT_FLAG)
+*/
+
+static void
+generate_callback_wrapper (gfc_symbol *vtab, gfc_symbol *derived,
+ gfc_namespace *ns, const char *tname,
+ gfc_component *vtab_cb)
+{
+ gfc_namespace *sub_ns;
+ gfc_code *last_code, *block;
+ gfc_symbol *callback, *cb, *token, *this_ptr, *scalar, *flag, *result;
+ gfc_symbol *c_ptr, *c_funptr, *c_null_funptr, *c_short;
+ gfc_expr *size;
+ int c_short_kind;
+ char *name;
+
+ /* Set up the namespace. */
+ sub_ns = gfc_get_namespace (ns, 0);
+ sub_ns->sibling = ns->contained;
+ ns->contained = sub_ns;
+ sub_ns->resolved = 1;
+
+ gfc_namespace *saved_ns = gfc_current_ns;
+ gfc_current_ns = sub_ns;
+ gfc_import_iso_c_binding_module ();
+ gfc_current_ns = saved_ns;
+ gfc_find_symbol ("c_ptr", sub_ns, 0, &c_ptr);
+ gfc_find_symbol ("c_funptr", sub_ns, 0, &c_funptr);
+ gfc_find_symbol ("c_null_funptr", sub_ns, 0, &c_null_funptr);
+ gfc_find_symbol ("c_short", sub_ns, 0, &c_short);
+ c_short_kind = mpz_get_si (c_short->value->value.integer);
+
+ /* Set up the procedure symbol. */
+ name = xasprintf ("__callback_%s", tname);
+ gfc_get_symbol (name, sub_ns, &callback);
+ free (name);
+ sub_ns->proc_name = callback;
+ callback->attr.flavor = FL_PROCEDURE;
+ callback->attr.function = 1;
+ callback->attr.pure = 0;
+ callback->attr.recursive = 1;
+ callback->attr.elemental = 1;
+ callback->result = callback;
+ callback->ts.type = BT_INTEGER;
+ callback->ts.kind = gfc_index_integer_kind;
+ callback->attr.artificial = 1;
+ callback->attr.always_explicit = 1;
+ callback->attr.if_source = IFSRC_DECL;
+ if (ns->proc_name && ns->proc_name->attr.flavor == FL_MODULE)
+ callback->module = ns->proc_name->name;
+ gfc_set_sym_referenced (callback);
+
+ /* Set up formal argument. */
+ gfc_get_symbol ("cb", sub_ns, &cb);
+ cb->attr.flavor = FL_PROCEDURE;
+ cb->attr.artificial = 1;
+ cb->attr.dummy = 1;
+ cb->attr.elemental = 1; // FIXME - that's not quite right.
+ cb->attr.function = 1;
+ cb->attr.intent = INTENT_IN;
+ cb->result = cb;
+ cb->ts.type = BT_INTEGER;
+ cb->ts.kind = gfc_index_integer_kind;
+ cb->attr.if_source = IFSRC_IFBODY;
+ gfc_set_sym_referenced (cb);
+ callback->formal = gfc_get_formal_arglist ();
+ callback->formal->sym = cb;
+ cb->formal_ns = gfc_get_namespace (sub_ns, 0);
+ cb->formal_ns->proc_name = cb;
+ /* cb_token. */
+ gfc_get_symbol ("cb_token", cb->formal_ns, &token);
+ token->ts.type = BT_DERIVED;
+ token->ts.u.derived = c_ptr;
+ token->attr.flavor = FL_VARIABLE;
+ token->attr.dummy = 1;
+ token->attr.value = 1;
+ token->attr.artificial = 1;
+ token->attr.intent = INTENT_IN;
+ gfc_set_sym_referenced (token);
+ cb->formal = gfc_get_formal_arglist ();
+ cb->formal->sym = token;
+ /* cb_var */
+ gfc_get_symbol ("cb_var", cb->formal_ns, &token);
+ token->ts.type = BT_DERIVED;
+ token->ts.u.derived = c_ptr;
+ token->attr.flavor = FL_VARIABLE;
+ token->attr.dummy = 1;
+ token->attr.artificial = 1;
+ token->attr.intent = INTENT_IN;
+ gfc_set_sym_referenced (token);
+ cb->formal->next = gfc_get_formal_arglist ();
+ cb->formal->next->sym = token;
+ /* cb_len */
+ gfc_get_symbol ("cb_len", cb->formal_ns, &token);
+ token->ts.type = BT_INTEGER;
+ token->ts.kind = gfc_index_integer_kind;
+ token->attr.flavor = FL_VARIABLE;
+ token->attr.dummy = 1;
+ token->attr.value = 1;
+ token->attr.artificial = 1;
+ token->attr.intent = INTENT_IN;
+ gfc_set_sym_referenced (token);
+ cb->formal->next->next = gfc_get_formal_arglist ();
+ cb->formal->next->next->sym = token;
+ /* cb_flag */
+ gfc_get_symbol ("cb_flag", cb->formal_ns, &token);
+ token->ts.type = BT_INTEGER;
+ token->ts.kind = c_short_kind;
+ token->attr.flavor = FL_VARIABLE;
+ token->attr.dummy = 1;
+ token->attr.value = 1;
+ token->attr.artificial = 1;
+ token->attr.intent = INTENT_IN;
+ gfc_set_sym_referenced (token);
+ cb->formal->next->next = gfc_get_formal_arglist ();
+ cb->formal->next->next->sym = token;
+ /* cb_fn */
+ gfc_get_symbol ("cb_fn", cb->formal_ns, &token);
+ token->ts.type = BT_DERIVED;
+ token->ts.u.derived = c_funptr;
+ token->attr.flavor = FL_VARIABLE;
+ token->attr.dummy = 1;
+ token->attr.elemental = 1;
+ token->attr.value = 1;
+ token->attr.artificial = 1;
+ token->attr.intent = INTENT_IN;
+ gfc_set_sym_referenced (token);
+ cb->formal->next->next->next = gfc_get_formal_arglist ();
+ cb->formal->next->next->next->sym = token;
+
+ /* Con't __callback_%s args. */
+ gfc_get_symbol ("token", sub_ns, &token);
+ token->ts.type = BT_DERIVED;
+ token->ts.u.derived = c_ptr;
+ token->attr.flavor = FL_VARIABLE;
+ token->attr.dummy = 1;
+ token->attr.value = 1;
+ token->attr.artificial = 1;
+ token->attr.intent = INTENT_IN;
+ gfc_set_sym_referenced (token);
+ callback->formal->next = gfc_get_formal_arglist ();
+ callback->formal->next->sym = token;
+
+ gfc_get_symbol ("this_ptr", sub_ns, &this_ptr);
+ this_ptr->ts.type = BT_DERIVED;
+ this_ptr->ts.u.derived = c_ptr;
+ this_ptr->attr.flavor = FL_VARIABLE;
+ this_ptr->attr.dummy = 1;
+ this_ptr->attr.value = 1;
+ this_ptr->attr.artificial = 1;
+ this_ptr->attr.intent = INTENT_IN;
+ gfc_set_sym_referenced (this_ptr);
+ callback->formal->next->next = gfc_get_formal_arglist ();
+ callback->formal->next->next->sym = this_ptr;
+
+ gfc_get_symbol ("flag", sub_ns, &flag);
+ flag->ts.type = BT_INTEGER;
+ flag->ts.kind = c_short_kind;
+ flag->attr.flavor = FL_VARIABLE;
+ flag->attr.dummy = 1;
+ flag->attr.contiguous = 1;
+ flag->attr.artificial = 1;
+ flag->attr.value = 1;
+ flag->attr.intent = INTENT_IN;
+ gfc_set_sym_referenced (flag);
+ callback->formal->next->next->next = gfc_get_formal_arglist ();
+ callback->formal->next->next->next->sym = flag;
+
+ /* Local var. */
+ gfc_get_symbol ("result", sub_ns, &result);
+ result->ts = callback->ts;
+ result->attr.flavor = FL_VARIABLE;
+ result->attr.result = 1;
+ callback->result = result;
+ gfc_set_sym_referenced (result);
+
+ gfc_get_symbol ("scalar", sub_ns, &scalar);
+ scalar->ts.type = BT_DERIVED;
+ scalar->ts.u.derived = derived;
+ scalar->attr.flavor = FL_VARIABLE;
+ scalar->attr.pointer = 1;
+ scalar->attr.artificial = 1;
+ gfc_set_sym_referenced (scalar);
+
+ /* Set return value to 0. */
+ last_code = gfc_get_code (EXEC_ASSIGN);
+ last_code->expr1 = gfc_lval_expr_from_sym (result);
+ last_code->expr2 = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+ sub_ns->code = last_code;
+
+ /* if (flag == GFC_CLASS_CALLBACK_VTABLE_FLAG)
+ return cb (token, scalar.vtab, c_sizeof (vtab),
+ GFC_CLASS_CB_VTABLE, NULL) */
+ last_code->next = gfc_get_code (EXEC_IF);
+ last_code = last_code->next;
+ last_code->block = gfc_get_code (EXEC_IF);
+ block = last_code->block;
+ block->expr1 = gfc_get_expr ();
+ block->expr1->expr_type = EXPR_OP;
+ block->expr1->where = gfc_current_locus;
+ block->expr1->ts.type = BT_LOGICAL;
+ block->expr1->ts.kind = 1;
+ block->expr1->value.op.op = INTRINSIC_EQ;
+ block->expr1->value.op.op1 = gfc_lval_expr_from_sym (flag);
+ block->expr1->value.op.op2
+ = gfc_get_int_expr (flag->ts.kind, NULL, GFC_CLASS_CALLBACK_VTABLE_FLAG);
+ size = gfc_get_expr ();
+ size->expr_type = EXPR_FUNCTION;
+ size->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_SIZEOF);
+ size->value.function.name = size->value.function.isym->name;
+ size->value.function.esym = NULL;
+ size->value.function.actual = gfc_get_actual_arglist ();
+ size->value.function.actual->expr = gfc_lval_expr_from_sym (vtab);
+ size->where = gfc_current_locus;
+ block->next = gfc_get_code (EXEC_ASSIGN);
+ block = block->next;
+ block->expr1 = gfc_lval_expr_from_sym (result);
+ block->expr2 = gfc_get_expr ();
+ block->expr2->expr_type = EXPR_FUNCTION;
+ block->expr2->ts = cb->ts;
+ block->expr2->where = gfc_current_locus;
+ block->expr2->symtree = gfc_find_symtree (sub_ns->sym_root, cb->name);
+ block->expr2->value.function.esym = cb;
+ block->expr2->value.function.esym->name = cb->name;
+ block->expr2->value.function.actual = gfc_get_actual_arglist ();
+ block->expr2->value.function.actual->expr = gfc_lval_expr_from_sym (token);
+ block->expr2->value.function.actual->next = gfc_get_actual_arglist ();
+ block->expr2->value.function.actual->next->expr
+ = gfc_lval_expr_from_sym (this_ptr);
+ block->expr2->value.function.actual->next->next
+ = gfc_get_actual_arglist ();
+ block->expr2->value.function.actual->next->next->expr = size;
+ block->expr2->value.function.actual->next->next->next
+ = gfc_get_actual_arglist ();
+ block->expr2->value.function.actual->next->next->next->expr
+ = gfc_get_int_expr (c_short_kind, NULL, GFC_CLASS_CB_VTABLE);
+ block->expr2->value.function.actual->next->next->next->next
+ = gfc_get_actual_arglist ();
+ block->expr2->value.function.actual->next->next->next->next->expr
+ = gfc_lval_expr_from_sym (c_null_funptr);
+
+ block->next = gfc_get_code (EXEC_RETURN);
+
+ /* call c_f_pointer (this_ptr, scalar) */
+ last_code->next = gfc_get_code (EXEC_CALL);
+ last_code = last_code->next;
+ gfc_get_sym_tree ("c_f_pointer", sub_ns, &last_code->symtree, false);
+ last_code->resolved_sym = last_code->symtree->n.sym;
+ last_code->resolved_isym
+ = gfc_intrinsic_subroutine_by_id (GFC_ISYM_C_F_POINTER);
+ last_code->ext.actual = gfc_get_actual_arglist ();
+ last_code->ext.actual->expr = gfc_lval_expr_from_sym (this_ptr);
+ last_code->ext.actual->next = gfc_get_actual_arglist ();
+ last_code->ext.actual->next->expr = gfc_lval_expr_from_sym (scalar);
+
+ /* Call now for pointer:
+ [class only:] cb (token, comp->_vptr, 3, NULL);
+ cb (token, comp(->_data), 0, NULL);
+ for allocatable:
+ [class only:] comp->_vptr->callback (cb, token, comp->var_vptr, 1)
+ cb (token, comp->var(.data), size, 1, NULL);
+ and then for allocatable of either class type or with allocatable comps
+ for each array element
+ cb (token, comp->var(.data), size, 0, var's cb fn); */
+ for (gfc_component *comp = derived->components; comp; comp = comp->next)
+ {
+ bool pointer = (comp->ts.type == BT_CLASS
+ ? CLASS_DATA (comp)->attr.pointer : comp->attr.pointer);
+ bool proc_ptr = comp->attr.proc_pointer;
+ if (!pointer && !proc_ptr && comp->ts.type != BT_CLASS
+ && !comp->attr.allocatable)
+ continue;
+
+ gfc_expr *expr = gfc_lval_expr_from_sym (scalar);
+ expr->ref = gfc_get_ref ();
+ expr->ref->type = REF_COMPONENT;
+ expr->ref->u.c.sym = derived;
+ expr->ref->u.c.component = comp;
+ expr->ts = comp->ts;
+
+ if (!proc_ptr && comp->ts.type != BT_CLASS && comp->attr.dimension)
+ {
+ gfc_ref *ref = expr->ref;
+ ref->next = gfc_get_ref ();
+ ref = ref->next;
+ ref->type = REF_ARRAY;
+ ref->u.ar.type = AR_FULL;
+ ref->u.ar.as = comp->as;
+ expr->rank = comp->as->rank;
+ }
+
+ if (pointer || proc_ptr)
+ size = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0);
+ else
+ {
+ size = gfc_get_expr ();
+ size->expr_type = EXPR_FUNCTION;
+ size->value.function.isym
+ = gfc_intrinsic_function_by_id (GFC_ISYM_SIZEOF);
+ size->value.function.name = size->value.function.isym->name;
+ size->value.function.esym = NULL;
+ size->value.function.actual = gfc_get_actual_arglist ();
+ size->value.function.actual->expr = gfc_copy_expr (expr);
+ size->where = gfc_current_locus;
+ }
+
+ if (!proc_ptr && comp->ts.type == BT_CLASS)
+ {
+ gfc_add_data_component (expr);
+ if (comp->attr.dimension)
+ {
+ gfc_ref *ref = expr->ref->next;
+ ref->next = gfc_get_ref ();
+ ref = ref->next;
+ ref->type = REF_ARRAY;
+ ref->u.ar.type = AR_FULL;
+ ref->u.ar.as = comp->as;
+ expr->rank = comp->as->rank;
+ }
+ }
+
+ /* if (allocated/associated(comp) */
+ last_code->next = gfc_get_code (EXEC_IF);
+ last_code = last_code->next;
+ last_code->block = gfc_get_code (EXEC_IF);
+ block = last_code->block;
+ block->expr1 = gfc_get_expr ();
+ block->expr1->expr_type = EXPR_FUNCTION;
+ block->expr1->ts.type = BT_LOGICAL;
+ block->expr1->ts.kind = 1;
+ block->expr1->value.function.isym
+ = gfc_intrinsic_function_by_id (pointer || proc_ptr
+ ? GFC_ISYM_ASSOCIATED
+ : GFC_ISYM_ALLOCATED);
+ block->expr1->value.function.name
+ = block->expr1->value.function.isym->name;
+ block->expr1->value.function.esym = NULL;
+ block->expr1->value.function.actual = gfc_get_actual_arglist ();
+ block->expr1->value.function.actual->expr = gfc_copy_expr (expr);
+ if (pointer || proc_ptr)
+ block->expr1->value.function.actual->next = gfc_get_actual_arglist ();
+ block->expr1->where = gfc_current_locus;
+
+ /* n += cb (token, &scalar->comp(._data), size, pointer ? 1 : 0, NULL) */
+
+ /* c_loc (scalar%comp) */
+ gfc_expr *loc_expr = gfc_get_expr ();
+ loc_expr->expr_type = EXPR_FUNCTION;
+ gfc_get_sym_tree ("c_loc", sub_ns, &loc_expr->symtree, false);
+ loc_expr->symtree->n.sym->attr.flavor = FL_PROCEDURE;
+ loc_expr->symtree->n.sym->intmod_sym_id = ISOCBINDING_LOC;
+ loc_expr->symtree->n.sym->attr.intrinsic = 1;
+ loc_expr->symtree->n.sym->from_intmod = INTMOD_ISO_C_BINDING;
+ loc_expr->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_C_LOC);
+ loc_expr->value.function.actual = gfc_get_actual_arglist ();
+ loc_expr->value.function.actual->expr = expr;
+ loc_expr->symtree->n.sym->result = expr->symtree->n.sym;
+ loc_expr->ts.type = BT_INTEGER;
+ loc_expr->ts.kind = gfc_index_integer_kind;
+ loc_expr->where = gfc_current_locus;
+
+ /* Call CB procedure for ptr assignment or allocatable copying. */
+ block->next = gfc_get_code (EXEC_ASSIGN);
+ block = block->next;
+ block->expr1 = gfc_lval_expr_from_sym (result);
+ block->expr2 = gfc_get_expr ();
+ block->expr2->ts = result->ts;
+ block->expr2->where = gfc_current_locus;
+ block->expr2->expr_type = EXPR_OP;
+ block->expr2->value.op.op = INTRINSIC_PLUS;
+ block->expr2->value.op.op1 = gfc_lval_expr_from_sym (result);
+ block->expr2->value.op.op2 = gfc_get_expr ();
+
+ gfc_expr *e = block->expr2->value.op.op2;
+ e->expr_type = EXPR_FUNCTION;
+ e->ts = cb->ts;
+ e->where = gfc_current_locus;
+ e->symtree = gfc_find_symtree (sub_ns->sym_root, cb->name);
+ e->value.function.esym = cb;
+ e->value.function.esym->name = cb->name;
+ e->value.function.actual = gfc_get_actual_arglist ();
+ e->value.function.actual->expr = gfc_lval_expr_from_sym (token);
+ e->value.function.actual->next = gfc_get_actual_arglist ();
+ e->value.function.actual->next->expr = loc_expr;
+ e->value.function.actual->next->next = gfc_get_actual_arglist ();
+ e->value.function.actual->next->next->expr = size;
+ e->value.function.actual->next->next->next = gfc_get_actual_arglist ();
+ e->value.function.actual->next->next->next->expr
+ = gfc_get_int_expr (c_short_kind, NULL,
+ proc_ptr ? GFC_CLASS_CB_PROC_POINTER
+ : (pointer ? GFC_CLASS_CB_POINTER
+ : GFC_CLASS_CB_ALLOCATABLE));
+ e->value.function.actual->next->next->next->next
+ = gfc_get_actual_arglist ();
+ e->value.function.actual->next->next->next->next->expr
+ = gfc_lval_expr_from_sym (c_null_funptr);
+
+ /* Call for each element cb when comp can have allocatable comps. */
+ if (((comp->ts.type != BT_DERIVED || !comp->ts.u.derived->attr.alloc_comp)
+ && comp->ts.type != BT_CLASS)
+ || pointer || proc_ptr)
+ continue;
+
+ gfc_expr *vtab_cb_expr;
+ if (comp->ts.type == BT_DERIVED)
+ vtab_cb_expr = gfc_lval_expr_from_sym (gfc_find_vtab (&comp->ts));
+ else
+ {
+ vtab_cb_expr = gfc_lval_expr_from_sym (scalar);
+ vtab_cb_expr->ref = gfc_get_ref ();
+ vtab_cb_expr->ref->type = REF_COMPONENT;
+ vtab_cb_expr->ref->u.c.sym = derived;
+ vtab_cb_expr->ref->u.c.component = comp;
+ gfc_add_vptr_component (vtab_cb_expr);
+ }
+ gfc_add_component_ref (vtab_cb_expr, "_callback");
+
+ block->next = gfc_get_code (EXEC_ASSIGN);
+ block = block->next;
+ block->expr1 = gfc_lval_expr_from_sym (result);
+ block->expr2 = gfc_get_expr ();
+ block->expr2->ts = result->ts;
+ block->expr2->where = gfc_current_locus;
+ block->expr2->expr_type = EXPR_OP;
+ block->expr2->value.op.op = INTRINSIC_PLUS;
+ block->expr2->value.op.op1 = gfc_lval_expr_from_sym (result);
+ block->expr2->value.op.op2 = gfc_get_expr ();
+ e = block->expr2->value.op.op2;
+
+ if (comp->attr.dimension)
+ {
+ e->expr_type = EXPR_FUNCTION;
+ e->ts = cb->ts;
+ e->where = gfc_current_locus;
+ e->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_SUM);
+ e->value.function.name = e->value.function.isym->name;
+ e->value.function.esym = NULL;
+ e->value.function.actual = gfc_get_actual_arglist ();
+ e->value.function.actual->next = gfc_get_actual_arglist ();
+ e->value.function.actual->next->next = gfc_get_actual_arglist ();
+ e->value.function.actual->expr = gfc_get_expr ();
+ e = e->value.function.actual->expr;
+ }
+
+ e->expr_type = EXPR_FUNCTION;
+ e->ts = cb->ts;
+ e->where = gfc_current_locus;
+ e->symtree = gfc_find_symtree (sub_ns->sym_root, cb->name);
+ e->value.function.esym = cb;
+ e->value.function.esym->name = cb->name;
+ e->value.function.actual = gfc_get_actual_arglist ();
+ e->value.function.actual->expr = gfc_lval_expr_from_sym (token);
+ e->value.function.actual->next = gfc_get_actual_arglist ();
+ e->value.function.actual->next->expr = gfc_copy_expr (expr);
+ e->value.function.actual->next->next = gfc_get_actual_arglist ();
+ e->value.function.actual->next->next->expr
+ = gfc_get_int_expr (gfc_index_integer_kind, NULL,
+ GFC_CLASS_CB_ALLOCATABLE);
+ e->value.function.actual->next->next->next = gfc_get_actual_arglist ();
+ e->value.function.actual->next->next->next->expr = vtab_cb_expr;
+ }
+
+ vtab_cb->initializer = gfc_lval_expr_from_sym (callback);
+ vtab_cb->ts.interface = callback;
+ gfc_commit_symbols ();
+}
/* Add procedure pointers for all type-bound procedures to a vtab. */
@@ -2423,6 +2930,8 @@ gfc_find_derived_vtab (gfc_symbol *derived)
c->initializer = gfc_get_null_expr (NULL);
}
+ vtab->ts.u.derived = vtype;
+
if (!derived->attr.unlimited_polymorphic
&& derived->components == NULL
&& !derived->attr.zero_comp)
@@ -2598,13 +3107,25 @@ gfc_find_derived_vtab (gfc_symbol *derived)
c->ts.interface = dealloc;
}
+ /* Add component _callback. */
+ if (!gfc_add_component (vtype, "_callback", &c))
+ goto cleanup;
+ c->attr.proc_pointer = 1;
+ c->attr.access = ACCESS_PRIVATE;
+ c->tb = XCNEW (gfc_typebound_proc);
+ c->tb->ppc = 1;
+ if (derived->attr.unlimited_polymorphic
+ || derived->attr.abstract)
+ c->initializer = gfc_get_null_expr (NULL);
+ else
+ generate_callback_wrapper (vtab, derived, ns, tname, c);
+
/* Add procedure pointers for type-bound procedures. */
if (!derived->attr.unlimited_polymorphic)
add_procs_to_declared_vtab (derived, vtype);
}
have_vtype:
- vtab->ts.u.derived = vtype;
vtab->value = gfc_default_initializer (&vtab->ts);
}
free (name);
@@ -126,6 +126,9 @@ static const struct attribute_spec gfc_attribute_table[] =
#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
@@ -164,6 +167,9 @@ static const struct attribute_spec gfc_attribute_table[] =
#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
@@ -3795,6 +3795,7 @@ void gfc_free_wait (gfc_wait *);
bool gfc_resolve_wait (gfc_wait *);
/* module.cc */
+void gfc_import_iso_c_binding_module (void);
void gfc_module_init_2 (void);
void gfc_module_done_2 (void);
void gfc_dump_module (const char *, int);
@@ -3856,6 +3857,13 @@ bool gfc_invalid_null_arg (gfc_expr *);
/* class.cc */
+#define GFC_CLASS_CALLBACK_DEFAULT_FLAG 0
+#define GFC_CLASS_CALLBACK_VTABLE_FLAG 1
+#define GFC_CLASS_CB_ALLOCATABLE 0
+#define GFC_CLASS_CB_POINTER 1
+#define GFC_CLASS_CB_PROC_POINTER 2
+#define GFC_CLASS_CB_VTABLE 3
+#define GFC_CLASS_CB_VPTR 4
void gfc_fix_class_refs (gfc_expr *e);
void gfc_add_component_ref (gfc_expr *, const char *);
void gfc_add_class_array_ref (gfc_expr *);
@@ -6410,6 +6410,8 @@ select_type_set_tmp (gfc_typespec *ts)
{
sym->attr.pointer
= CLASS_DATA (selector)->attr.class_pointer;
+ sym->attr.allocatable
+ = CLASS_DATA (selector)->attr.allocatable;
/* Copy across the array spec to the selector. */
if (CLASS_DATA (selector)->attr.dimension
@@ -84,7 +84,7 @@ along with GCC; see the file COPYING3. If not see
/* Don't put any single quote (') in MOD_VERSION, if you want it to be
recognized. */
-#define MOD_VERSION "15"
+#define MOD_VERSION "16"
/* Structure that describes a position within a module file. */
@@ -6633,7 +6633,7 @@ create_intrinsic_function (const char *name, int id,
list was provided. */
static void
-import_iso_c_binding_module (void)
+import_iso_c_binding_module (bool import_all)
{
gfc_symbol *mod_sym = NULL, *return_type;
gfc_symtree *mod_symtree = NULL, *tmp_symtree;
@@ -6704,16 +6704,17 @@ import_iso_c_binding_module (void)
}
}
- if ((want_c_ptr || !only_flag) && !c_ptr)
+ if ((want_c_ptr || !only_flag || import_all) && !c_ptr)
c_ptr = generate_isocbinding_symbol (iso_c_module_name,
(iso_c_binding_symbol)
ISOCBINDING_PTR,
- NULL, NULL, only_flag);
- if ((want_c_funptr || !only_flag) && !c_funptr)
+ NULL, NULL, only_flag && !import_all);
+ if ((want_c_funptr || !only_flag || import_all) && !c_funptr)
c_funptr = generate_isocbinding_symbol (iso_c_module_name,
(iso_c_binding_symbol)
ISOCBINDING_FUNPTR,
- NULL, NULL, only_flag);
+ NULL, NULL,
+ only_flag && !import_all);
/* Generate the symbols for the named constants representing
the kinds for intrinsic data types. */
@@ -6812,7 +6813,7 @@ import_iso_c_binding_module (void)
}
}
- if (!found && !only_flag)
+ if (!found && !only_flag && !import_all)
{
/* Skip, if the symbol is not in the enabled standard. */
switch (i)
@@ -6846,7 +6847,9 @@ import_iso_c_binding_module (void)
default:
; /* Not GFC_STD_* versioned. */
}
-
+ }
+ if (!found && (!only_flag || import_all))
+ {
switch (i)
{
#define NAMED_FUNCTION(a,b,c,d) \
@@ -6896,6 +6899,13 @@ import_iso_c_binding_module (void)
}
}
+void
+gfc_import_iso_c_binding_module (void)
+{
+ gcc_assert (gfc_rename_list == NULL);
+ import_iso_c_binding_module (true);
+}
+
/* Add an integer named constant from a given module. */
@@ -7305,7 +7315,7 @@ gfc_use_module (gfc_use_list *module)
if (strcmp (module_name, "iso_c_binding") == 0
&& gfc_notify_std (GFC_STD_F2003, "ISO_C_BINDING module at %C"))
{
- import_iso_c_binding_module();
+ import_iso_c_binding_module (false);
free_rename (module->rename);
module->rename = NULL;
gfc_current_locus = old_locus;
@@ -7041,13 +7041,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 (list == OMP_LIST_MAP && !openacc)
switch (code->op)
{
@@ -488,7 +488,8 @@ gfc_resolve_formal_arglist (gfc_symbol *proc)
continue;
}
- if (sym->attr.flavor == FL_PROCEDURE)
+ if (sym->attr.flavor == FL_PROCEDURE
+ && !proc->attr.artificial && !sym->attr.artificial)
{
gfc_error ("Dummy procedure %qs not allowed in elemental "
"procedure %qs at %L", sym->name, proc->name,
@@ -1875,7 +1876,8 @@ gfc_resolve_intrinsic (gfc_symbol *sym, locus *loc)
sym->attr.elemental = isym->elemental;
/* Check it is actually available in the standard settings. */
- if (!gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at))
+ if ((!sym->ns->proc_name || !sym->ns->proc_name->attr.artificial)
+ && !gfc_check_intrinsic_standard (isym, &symstd, false, sym->declared_at))
{
gfc_error ("The intrinsic %qs declared INTRINSIC at %L is not "
"available in the current standard settings but %s. Use "
@@ -13381,7 +13383,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
name, &sym->declared_at);
return false;
}
- if (sym->attr.dummy)
+ if (sym->attr.dummy && !sym->attr.artificial)
{
gfc_error ("Dummy procedure %qs at %L shall not be elemental",
sym->name, &sym->declared_at);
@@ -17468,7 +17470,8 @@ resolve_types (gfc_namespace *ns)
for (n = ns->contained; n; n = n->sibling)
{
- if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name))
+ if (gfc_pure (ns->proc_name) && !gfc_pure (n->proc_name)
+ && (!n->proc_name || !n->proc_name->attr.artificial))
gfc_error ("Contained procedure %qs at %L of a PURE procedure must "
"also be PURE", n->proc_name->name,
&n->proc_name->declared_at);
@@ -465,9 +465,11 @@ gfc_conv_descriptor_stride_get (tree desc, tree dim)
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
if (integer_zerop (dim)
&& (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
- ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
- ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
- ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
return gfc_index_one_node;
return gfc_conv_descriptor_stride (desc, dim);
@@ -8051,7 +8053,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
/* Calculate the array size (number of elements); if dim != NULL_TREE,
- return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P). */
+ return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P).
+ If !expr && descriptor array, the rank is taken from the descriptor. */
tree
gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim)
{
@@ -8061,20 +8064,21 @@ gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim)
return GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
}
tree size, tmp, rank = NULL_TREE, cond = NULL_TREE;
- symbol_attribute attr = gfc_expr_attr (expr);
- gfc_array_spec *as = gfc_get_full_arrayspec_from_expr (expr);
gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
- if ((!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK)
- || !dim)
- {
- if (expr->rank < 0)
- rank = fold_convert (signed_char_type_node,
- gfc_conv_descriptor_rank (desc));
- else
- rank = build_int_cst (signed_char_type_node, expr->rank);
- }
+ /* Nonallocatable, nonpointer assumed-rank array. */
+ enum gfc_array_kind akind = GFC_TYPE_ARRAY_AKIND (TREE_TYPE (desc));
+ bool assumed_rank = (akind == GFC_ARRAY_ASSUMED_RANK_CONT
+ || akind == GFC_ARRAY_ASSUMED_RANK
+ || akind == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
+ || akind == GFC_ARRAY_ASSUMED_RANK_POINTER
+ || akind == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT);
+ if (expr == NULL || expr->rank < 0)
+ rank = fold_convert (signed_char_type_node,
+ gfc_conv_descriptor_rank (desc));
+ else
+ rank = build_int_cst (signed_char_type_node, expr->rank);
- if (dim || expr->rank == 1)
+ if (dim || (expr && expr->rank == 1))
{
if (!dim)
dim = gfc_index_zero_node;
@@ -8091,8 +8095,8 @@ gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim)
size = max (0, size); */
size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
size, gfc_index_zero_node);
- if (!attr.pointer && !attr.allocatable
- && as && as->type == AS_ASSUMED_RANK)
+ if (assumed_rank && (akind == GFC_ARRAY_ASSUMED_RANK_CONT
+ || akind == GFC_ARRAY_ASSUMED_RANK))
{
tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
rank, build_int_cst (signed_char_type_node, 1));
@@ -8133,7 +8137,8 @@ gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim)
extent = 0
size *= extent. */
cond = NULL_TREE;
- if (!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK)
+ if (assumed_rank && (akind == GFC_ARRAY_ASSUMED_RANK_CONT
+ || akind == GFC_ARRAY_ASSUMED_RANK))
{
tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
rank, build_int_cst (signed_char_type_node, 1));
@@ -8625,7 +8630,10 @@ gfc_full_array_size (stmtblock_t *block, tree decl, int rank)
tree idx;
tree nelems;
tree tmp;
- idx = gfc_rank_cst[rank - 1];
+ if (rank < 0)
+ idx = gfc_conv_descriptor_rank (decl);
+ else
+ idx = gfc_rank_cst[rank - 1];
nelems = gfc_conv_descriptor_ubound_get (decl, idx);
tmp = gfc_conv_descriptor_lbound_get (decl, idx);
tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
@@ -204,6 +204,7 @@ gfc_get_ultimate_alloc_ptr_comps_caf_token (gfc_se *outerse, gfc_expr *expr)
#define VTABLE_COPY_FIELD 4
#define VTABLE_FINAL_FIELD 5
#define VTABLE_DEALLOCATE_FIELD 6
+#define VTABLE_CALLBACK_FIELD 7
tree
@@ -383,6 +384,7 @@ VTAB_GET_FIELD_GEN (def_init, VTABLE_DEF_INIT_FIELD)
VTAB_GET_FIELD_GEN (copy, VTABLE_COPY_FIELD)
VTAB_GET_FIELD_GEN (final, VTABLE_FINAL_FIELD)
VTAB_GET_FIELD_GEN (deallocate, VTABLE_DEALLOCATE_FIELD)
+VTAB_GET_FIELD_GEN (callback, VTABLE_CALLBACK_FIELD)
#undef VTAB_GET_FIELD_GEN
/* The size field is returned as an array index type. Therefore treat
@@ -420,6 +422,9 @@ gfc_vptr_size_get (tree vptr)
#undef VTABLE_DEF_INIT_FIELD
#undef VTABLE_COPY_FIELD
#undef VTABLE_FINAL_FIELD
+#undef VTABLE_DEALLOCATE_FIELD
+#undef VTABLE_CALLBACK_FIELD
+
/* IF ts is null (default), search for the last _class ref in the chain
@@ -9496,7 +9501,8 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr, bool add_clobber)
if (expr->ts.type == BT_CHARACTER)
{
gfc_conv_expr (se, expr);
- gfc_conv_string_parameter (se);
+ if (expr->expr_type != EXPR_VARIABLE || !gfc_expr_attr (expr).proc_pointer)
+ gfc_conv_string_parameter (se);
return;
}
@@ -9554,6 +9560,9 @@ gfc_conv_expr_reference (gfc_se * se, gfc_expr * expr, bool add_clobber)
TREE_STATIC (var) = 1;
pushdecl (var);
}
+ else if (expr->expr_type == EXPR_VARIABLE
+ && (DECL_P (se->expr) || TREE_CODE (se->expr) == COMPONENT_REF))
+ var = se->expr;
else
{
var = gfc_create_var (TREE_TYPE (se->expr), NULL);
@@ -8099,12 +8099,18 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
class object. The class object may be a non-pointer object, e.g.
located on the stack, or a memory location pointed to, e.g. a
parameter, i.e., an indirect_ref. */
- if (arg->rank < 0
- || (arg->rank > 0 && !VAR_P (argse.expr)
- && ((INDIRECT_REF_P (TREE_OPERAND (argse.expr, 0))
- && GFC_DECL_CLASS (TREE_OPERAND (
- TREE_OPERAND (argse.expr, 0), 0)))
- || GFC_DECL_CLASS (TREE_OPERAND (argse.expr, 0)))))
+ if (POINTER_TYPE_P (TREE_TYPE (argse.expr))
+ && GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (argse.expr))))
+ byte_size
+ = gfc_class_vtab_size_get (build_fold_indirect_ref (argse.expr));
+ else if (GFC_CLASS_TYPE_P (TREE_TYPE (argse.expr)))
+ byte_size = gfc_class_vtab_size_get (argse.expr);
+ else if (arg->rank < 0
+ || (arg->rank > 0 && !VAR_P (argse.expr)
+ && ((INDIRECT_REF_P (TREE_OPERAND (argse.expr, 0))
+ && GFC_DECL_CLASS (TREE_OPERAND (
+ TREE_OPERAND (argse.expr, 0), 0)))
+ || GFC_DECL_CLASS (TREE_OPERAND (argse.expr, 0)))))
byte_size = gfc_class_vtab_size_get (TREE_OPERAND (argse.expr, 0));
else if (arg->rank > 0
|| (arg->rank == 0
@@ -8114,7 +8120,7 @@ gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
byte_size = gfc_class_vtab_size_get (
GFC_DECL_SAVED_DESCRIPTOR (arg->symtree->n.sym->backend_decl));
else
- byte_size = gfc_class_vtab_size_get (argse.expr);
+ gcc_unreachable ();
}
else
{
@@ -8899,13 +8905,13 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr)
if (scalar)
{
/* A pointer to a scalar. */
+ symbol_attribute attr = gfc_expr_attr (arg1->expr);
arg1se.want_pointer = 1;
gfc_conv_expr (&arg1se, arg1->expr);
- if (arg1->expr->symtree->n.sym->attr.proc_pointer
- && arg1->expr->symtree->n.sym->attr.dummy)
+ if (attr.proc_pointer && attr.dummy)
arg1se.expr = build_fold_indirect_ref_loc (input_location,
arg1se.expr);
- if (arg1->expr->ts.type == BT_CLASS)
+ if (!attr.proc_pointer && arg1->expr->ts.type == BT_CLASS)
{
tmp2 = gfc_class_data_get (arg1se.expr);
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp2)))
@@ -9525,13 +9531,6 @@ conv_isocbinding_function (gfc_se *se, gfc_expr *expr)
gfc_conv_expr_descriptor (se, arg->expr);
se->expr = gfc_conv_descriptor_data_get (se->expr);
}
-
- /* TODO -- the following two lines shouldn't be necessary, but if
- they're removed, a bug is exposed later in the code path.
- This workaround was thus introduced, but will have to be
- removed; please see PR 35150 for details about the issue. */
- se->expr = convert (pvoid_type_node, se->expr);
- se->expr = gfc_evaluate_now (se->expr, &se->pre);
}
else if (expr->value.function.isym->id == GFC_ISYM_C_FUNLOC)
gfc_conv_expr_reference (se, arg->expr);
@@ -25,9 +25,15 @@ 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 "tree-pass.h" /* for PROP_gimple_any */
+#include "function.h"
+#include "gimple.h"
#include "gimple-expr.h"
#include "trans.h"
#include "stringpool.h"
+#include "cgraph.h"
#include "fold-const.h"
#include "gimplify.h" /* For create_tmp_var_raw. */
#include "trans-stmt.h"
@@ -40,6 +46,9 @@ along with GCC; see the file COPYING3. If not see
#include "omp-general.h"
#include "omp-low.h"
#include "memmodel.h" /* For MEMMODEL_ enums. */
+#include "stor-layout.h"
+#include "gimple-iterator.h"
+#include "gimplify-me.h"
#undef GCC_DIAG_STYLE
#define GCC_DIAG_STYLE __gcc_tdiag__
@@ -323,22 +332,25 @@ 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. */
static bool
-gfc_has_alloc_comps (tree type, tree decl)
+gfc_has_alloc_comps (tree type, tree decl, bool ptr_ok)
{
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;
@@ -357,7 +369,7 @@ 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 (gfc_has_alloc_comps (ftype, field, false))
return true;
}
return false;
@@ -435,7 +447,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;
@@ -575,7 +587,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)
@@ -699,7 +711,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);
@@ -752,7 +764,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),
@@ -888,7 +900,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);
@@ -947,7 +959,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),
@@ -992,7 +1004,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. */
@@ -1014,7 +1026,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);
@@ -1129,7 +1141,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),
@@ -1376,7 +1388,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);
@@ -1396,7 +1408,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;
@@ -1493,6 +1505,7 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc)
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)
@@ -1501,7 +1514,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);
@@ -1514,14 +1527,14 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc)
{
c2 = build_omp_clause (input_location, 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;
@@ -1538,10 +1551,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)))
@@ -1584,7 +1597,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);
@@ -1597,15 +1610,33 @@ 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 (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
- || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)
+ 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
+ || akind == GFC_ARRAY_POINTER_CONT
+ || akind == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
+ || akind == GFC_ARRAY_ASSUMED_RANK_POINTER
+ || akind == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT)
{
stmtblock_t cond_block;
tree tem, then_b, else_b, zero, cond;
+ int rank = ((akind == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
+ || akind == GFC_ARRAY_ASSUMED_RANK_POINTER
+ || akind == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT)
+ ? -1 : GFC_TYPE_ARRAY_RANK (type));
gfc_init_block (&cond_block);
- tem = gfc_full_array_size (&cond_block, decl,
- GFC_TYPE_ARRAY_RANK (type));
+ tem = gfc_full_array_size (&cond_block, unshare_expr (decl), rank);
gfc_add_modify (&cond_block, size, tem);
gfc_add_modify (&cond_block, size,
fold_build2 (MULT_EXPR, gfc_array_index_type,
@@ -1615,7 +1646,7 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc)
zero = build_int_cst (gfc_array_index_type, 0);
gfc_add_modify (&cond_block, size, zero);
else_b = gfc_finish_block (&cond_block);
- tem = gfc_conv_descriptor_data_get (decl);
+ tem = gfc_conv_descriptor_data_get (unshare_expr (decl));
tem = fold_convert (pvoid_type_node, tem);
cond = fold_build2_loc (input_location, NE_EXPR,
boolean_type_node, tem, null_pointer_node);
@@ -1632,11 +1663,13 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc)
{
stmtblock_t cond_block;
tree then_b;
-
+ int rank = ((akind == GFC_ARRAY_ASSUMED_RANK
+ || akind == GFC_ARRAY_ASSUMED_RANK_CONT)
+ ? -1 : GFC_TYPE_ARRAY_RANK (type));
gfc_init_block (&cond_block);
gfc_add_modify (&cond_block, size,
- gfc_full_array_size (&cond_block, decl,
- GFC_TYPE_ARRAY_RANK (type)));
+ gfc_full_array_size (&cond_block, unshare_expr (decl),
+ rank));
gfc_add_modify (&cond_block, size,
fold_build2 (MULT_EXPR, gfc_array_index_type,
size, elemsz));
@@ -1647,9 +1680,12 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc)
}
else
{
+ int rank = ((akind == GFC_ARRAY_ASSUMED_RANK
+ || akind == GFC_ARRAY_ASSUMED_RANK_CONT)
+ ? -1 : GFC_TYPE_ARRAY_RANK (type));
gfc_add_modify (&block, size,
- gfc_full_array_size (&block, decl,
- GFC_TYPE_ARRAY_RANK (type)));
+ gfc_full_array_size (&block, unshare_expr (decl),
+ rank));
gfc_add_modify (&block, size,
fold_build2 (MULT_EXPR, gfc_array_index_type,
size, elemsz));
@@ -1658,11 +1694,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);
@@ -1685,6 +1740,1289 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc)
}
}
+#define GFC_MAP_TOKEN_DATA 0
+#define GFC_MAP_TOKEN_SIZES 1
+#define GFC_MAP_TOKEN_KINDS 2
+#define GFC_MAP_TOKEN_DATA_OFFSET 3
+#define GFC_MAP_TOKEN_OFFSET 4
+#define GFC_MAP_TOKEN_FLAGS 5
+#define GFC_MAP_TOKEN_DETACH 6
+
+static tree
+gfc_omp_get_token_data (tree token)
+{
+ token = TYPE_FIELDS (TREE_TYPE (token));
+ return gfc_advance_chain (token, GFC_MAP_TOKEN_DATA);
+}
+
+static tree
+gfc_omp_get_token_sizes (tree token)
+{
+ token = TYPE_FIELDS (TREE_TYPE (token));
+ return gfc_advance_chain (token, GFC_MAP_TOKEN_SIZES);
+}
+
+static tree
+gfc_omp_get_token_kinds (tree token)
+{
+ token = TYPE_FIELDS (TREE_TYPE (token));
+ return gfc_advance_chain (token, GFC_MAP_TOKEN_KINDS);
+}
+
+static tree
+gfc_omp_get_token_offset_data (tree token)
+{
+ token = TYPE_FIELDS (TREE_TYPE (token));
+ return gfc_advance_chain (token, GFC_MAP_TOKEN_DATA_OFFSET);
+}
+
+static tree
+gfc_omp_get_token_offset (tree token)
+{
+ token = TYPE_FIELDS (TREE_TYPE (token));
+ return gfc_advance_chain (token, GFC_MAP_TOKEN_OFFSET);
+}
+
+static tree
+gfc_omp_get_token_flags (tree token)
+{
+ token = TYPE_FIELDS (TREE_TYPE (token));
+ return gfc_advance_chain (token, GFC_MAP_TOKEN_FLAGS);
+}
+
+static tree
+gfc_omp_get_token_detach (tree token)
+{
+ token = TYPE_FIELDS (TREE_TYPE (token));
+ return gfc_advance_chain (token, GFC_MAP_TOKEN_DETACH);
+}
+
+#undef GFC_MAP_TOKEN_DATA
+#undef GFC_MAP_TOKEN_SIZES
+#undef GFC_MAP_TOKEN_KINDS
+#undef GFC_MAP_TOKEN_OFFSET_DATA
+#undef GFC_MAP_TOKEN_OFFSET
+#undef GFC_MAP_TOKEN_FLAGS
+#undef GFC_MAP_TOKEN_DETACH
+
+/* Returns a record type to store the arrays used for mapping. */
+static tree
+gfc_omp_get_map_token_type (bool pointer)
+{
+ static tree decl = NULL_TREE;
+ if (decl != NULL_TREE)
+ return pointer ? build_pointer_type (decl) : decl;
+ decl = make_node (RECORD_TYPE);
+ TYPE_NAME (decl) = get_identifier ("map_token_t");
+ TYPE_NAMELESS (decl) = 1;
+
+ tree type = ptr_type_node;
+ type = build_pointer_type (ptr_type_node);
+ tree field = build_decl (UNKNOWN_LOCATION, FIELD_DECL,
+ get_identifier ("data"), type);
+ TYPE_FIELDS (decl) = field;
+ DECL_CONTEXT (field) = decl;
+ suppress_warning (field);
+
+ type = build_pointer_type (size_type_node);
+ tree field2 = build_decl (UNKNOWN_LOCATION, FIELD_DECL,
+ get_identifier ("sizes"), type);
+ DECL_CHAIN (field) = field2;
+ DECL_CONTEXT (field2) = decl;
+ suppress_warning (field2);
+
+ type = build_pointer_type (short_unsigned_type_node);
+ field = build_decl (UNKNOWN_LOCATION, FIELD_DECL,
+ get_identifier ("kinds"), type);
+ DECL_CHAIN (field2) = field;
+ DECL_CONTEXT (field) = decl;
+ suppress_warning (field);
+
+ field2 = build_decl (UNKNOWN_LOCATION, FIELD_DECL,
+ get_identifier ("offset_data"), size_type_node);
+ DECL_CHAIN (field) = field2;
+ DECL_CONTEXT (field2) = decl;
+ suppress_warning (field2);
+
+ field = build_decl (UNKNOWN_LOCATION, FIELD_DECL,
+ get_identifier ("offset"), size_type_node);
+ DECL_CHAIN (field2) = field;
+ DECL_CONTEXT (field) = decl;
+ suppress_warning (field);
+
+ field2 = build_decl (UNKNOWN_LOCATION, FIELD_DECL,
+ get_identifier ("flags"), short_unsigned_type_node);
+ DECL_CHAIN (field) = field2;
+ DECL_CONTEXT (field2) = decl;
+ suppress_warning (field2);
+
+ field = build_decl (UNKNOWN_LOCATION, FIELD_DECL,
+ get_identifier ("detach"), boolean_type_node);
+ DECL_CHAIN (field2) = field;
+ DECL_CONTEXT (field) = decl;
+ suppress_warning (field);
+
+ layout_type (decl);
+
+ return pointer ? build_pointer_type (decl) : decl;
+}
+
+
+/* Returns the type of the Fortran __callback_<derived-type> function. */
+static tree
+gfc_omp_get_cb_type ()
+{
+ tree type;
+ type = build_function_type_list (size_type_node, ptr_type_node, NULL_TREE);
+ type = build_pointer_type (type);
+ type = build_function_type_list (size_type_node, ptr_type_node, ptr_type_node,
+ size_type_node, type, NULL_TREE);
+ type = build_function_type_list (size_type_node, type, ptr_type_node,
+ ptr_type_node, NULL_TREE);
+ return type;
+}
+
+/* Generate call back function, either one which counts alloc comps
+ or one which maps. */
+
+static tree
+gfc_omp_gen_deep_map_fn (bool count_fn)
+{
+ tree old_context = current_function_decl;
+ tree decl, type, tmp, cb_fn, token, data, size, flag;
+ location_t loc = UNKNOWN_LOCATION;
+
+ if (old_context)
+ {
+ push_function_context ();
+ current_function_decl = NULL_TREE;
+ }
+
+ type = gfc_omp_get_cb_type ();
+ type = build_pointer_type (type);
+ type = build_function_type_list (size_type_node,
+ count_fn ? ptr_type_node
+ : gfc_omp_get_map_token_type (true),
+ build_pointer_type (ptr_type_node),
+ size_type_node, short_integer_type_node,
+ type, NULL_TREE);
+ decl = build_decl (loc, FUNCTION_DECL,
+ get_identifier (count_fn ? GFC_PREFIX ("omp_count")
+ : GFC_PREFIX ("omp_map")), type);
+ TREE_STATIC (decl) = 1;
+ TREE_USED (decl) = 1;
+ DECL_ARTIFICIAL (decl) = 1;
+ DECL_IGNORED_P (decl) = 0;
+ DECL_UNINLINABLE (decl) = 1;
+ TREE_PUBLIC (decl) = 0;
+ DECL_EXTERNAL (decl) = 0;
+ DECL_INITIAL (decl) = make_node (BLOCK);
+ BLOCK_SUPERCONTEXT (DECL_INITIAL (decl)) = decl;
+
+ tmp = build_decl (loc, RESULT_DECL, NULL_TREE, size_type_node);
+ DECL_ARTIFICIAL (tmp) = 1;
+ DECL_IGNORED_P (tmp) = 1;
+ DECL_CONTEXT (tmp) = decl;
+ DECL_RESULT (decl) = tmp;
+
+ /* Declare its args. */
+ tree arglist = NULL_TREE;
+ tree typelist = TYPE_ARG_TYPES (TREE_TYPE (decl));
+ tmp = TREE_VALUE (typelist);
+ token = build_decl (loc, PARM_DECL, get_identifier ("token"), tmp);
+ DECL_CONTEXT (token) = decl;
+ DECL_ARG_TYPE (token) = TREE_VALUE (typelist);
+ TREE_READONLY (token) = 1;
+ arglist = chainon (arglist, token);
+
+ typelist = TREE_CHAIN (typelist);
+ tmp = TREE_VALUE (typelist);
+ data = build_decl (loc, PARM_DECL, get_identifier ("data"), tmp);
+ DECL_CONTEXT (data) = decl;
+ DECL_ARG_TYPE (data) = TREE_VALUE (typelist);
+ TREE_READONLY (data) = 1;
+ arglist = chainon (arglist, data);
+
+ typelist = TREE_CHAIN (typelist);
+ tmp = TREE_VALUE (typelist);
+ size = build_decl (loc, PARM_DECL, get_identifier ("size"), tmp);
+ DECL_CONTEXT (size) = decl;
+ DECL_ARG_TYPE (size) = TREE_VALUE (typelist);
+ TREE_READONLY (size) = 1;
+ arglist = chainon (arglist, size);
+
+ typelist = TREE_CHAIN (typelist);
+ tmp = TREE_VALUE (typelist);
+ flag = build_decl (loc, PARM_DECL, get_identifier ("flag"), tmp);
+ DECL_CONTEXT (flag) = decl;
+ DECL_ARG_TYPE (flag) = TREE_VALUE (typelist);
+ TREE_READONLY (flag) = 1;
+ arglist = chainon (arglist, flag);
+
+ typelist = TREE_CHAIN (typelist);
+ tmp = TREE_VALUE (typelist);
+ cb_fn = build_decl (loc, PARM_DECL, get_identifier ("cb_fn"), tmp);
+ DECL_CONTEXT (cb_fn) = decl;
+ DECL_ARG_TYPE (cb_fn) = TREE_VALUE (typelist);
+ TREE_READONLY (cb_fn) = 1;
+ arglist = chainon (arglist, cb_fn);
+
+ DECL_ARGUMENTS (decl) = arglist;
+ push_struct_function (decl);
+ push_gimplify_context (true);
+ init_tree_ssa (cfun);
+
+ /* Body. */
+ gimple_seq seq = NULL;
+
+ /* n = 0 */
+ if (count_fn)
+ {
+ /* For allocatables + vtable:
+ if ((flag == GFC_CLASS_CB_ALLOCATABLE || flag == GFC_CLASS_CB_VTABLE)
+ && size != 0)
+ n = 1;
+ if ((flag == GFC_CLASS_CB_ALLOCATABLE || flag == GFC_CLASS_CB_VTABLE)
+ && size != 0 && cb_fn)
+ n = n + cb_fn (...)
+ return n; */
+ tree num = build_decl (loc, VAR_DECL, create_tmp_var_name ("n"),
+ size_type_node);
+ tmp = fold_build2_loc (loc, MODIFY_EXPR, size_type_node, num,
+ build_int_cst (size_type_node,
+ GFC_CLASS_CB_ALLOCATABLE));
+ gimplify_and_add (tmp, &seq);
+
+ tmp = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, flag,
+ build_zero_cst (short_integer_type_node));
+ tree cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, flag,
+ build_int_cst (short_integer_type_node,
+ GFC_CLASS_CB_VTABLE));
+ tmp = fold_build2_loc (loc, TRUTH_OR_EXPR, boolean_type_node, tmp, cond);
+ cond = fold_build2_loc (loc, NE_EXPR, boolean_type_node, size,
+ build_zero_cst (size_type_node));
+ cond = fold_build2_loc (loc, TRUTH_AND_EXPR, boolean_type_node,
+ tmp, cond);
+ tmp = build3 (COND_EXPR, void_type_node, cond,
+ fold_build2_loc (loc, MODIFY_EXPR, size_type_node,
+ num, build_int_cst (size_type_node, 1)),
+ build_empty_stmt (loc));
+ gimplify_and_add (tmp, &seq);
+
+ tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node,
+ cb_fn, null_pointer_node);
+ cond = fold_build2_loc (loc, TRUTH_AND_EXPR, boolean_type_node,
+ cond, tmp);
+ tmp = build_call_expr_loc (loc, build_fold_indirect_ref_loc (loc, cb_fn),
+ 4, build_fold_addr_expr (decl), token,
+ build_fold_indirect_ref_loc (loc, data),
+ build_int_cst (short_integer_type_node,
+ GFC_CLASS_CALLBACK_DEFAULT_FLAG));
+ tmp = fold_build2_loc (loc, PLUS_EXPR, size_type_node, num, tmp);
+ tmp = build3 (COND_EXPR, void_type_node, cond,
+ fold_build2_loc (loc, MODIFY_EXPR, size_type_node,
+ num, tmp), build_empty_stmt (loc));
+ gimplify_and_add (tmp, &seq);
+
+ tmp = fold_build2_loc (loc, MODIFY_EXPR, size_type_node,
+ DECL_RESULT (decl), num);
+ tmp = fold_build1_loc (loc, RETURN_EXPR, void_type_node, tmp);
+ gimplify_and_add (tmp, &seq);
+ }
+ else
+ {
+ /* Map allocatables and the vtable
+ if (flag != 0 && flag != 2) || size == 0)
+ goto return_label
+ map(<flag>: <*token.data> [len: <size>])
+ map((token.detach ? detach : attach):
+ <token.data> [pointer assign, bias: 0])
+ if (!cb_fn)
+ goto return_label
+ cb_fn (...)
+ return_label:
+ return 0 */
+
+ tree return_label = create_artificial_label (loc);
+ tree cont_label = create_artificial_label (loc);
+ tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node, flag,
+ build_int_cst (short_integer_type_node,
+ GFC_CLASS_CB_ALLOCATABLE));
+ tree cond = fold_build2_loc (loc, NE_EXPR, boolean_type_node, flag,
+ build_int_cst (short_integer_type_node,
+ GFC_CLASS_CB_VTABLE));
+ tmp = fold_build2_loc (loc, TRUTH_AND_EXPR, boolean_type_node, tmp, cond);
+ cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, size,
+ build_zero_cst (size_type_node));
+ cond = fold_build2_loc (loc, TRUTH_OR_EXPR, boolean_type_node,
+ tmp, cond);
+ tmp = build3 (COND_EXPR, void_type_node, cond,
+ fold_build1_loc (loc, GOTO_EXPR, void_type_node,
+ return_label), build_empty_stmt (loc));
+ gimplify_and_add (tmp, &seq);
+
+ gimple_seq_add_stmt (&seq,
+ gimple_build_cond (EQ_EXPR, size, size_zero_node,
+ return_label, cont_label));
+ gimple_seq_add_stmt (&seq, gimple_build_label (cont_label));
+
+ /* data[offset_data] = *token.data; */
+ token = build_fold_indirect_ref_loc (loc, token);
+ tree one = build_int_cst (size_type_node, 1);
+ tree field = gfc_omp_get_token_data (token);
+ tree offset_field = gfc_omp_get_token_offset_data (token);
+ tree offset = fold_build3_loc (loc, COMPONENT_REF,
+ TREE_TYPE (offset_field), token,
+ offset_field, NULL_TREE);
+ tree tmp = fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field),
+ token, field, NULL_TREE);
+ tmp = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (tmp), tmp,
+ build2_loc (loc, MULT_EXPR, size_type_node,
+ TYPE_SIZE_UNIT (ptr_type_node), offset));
+ 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, build_fold_indirect_ref_loc (loc, data), &seq);
+
+ /* token.offset_data++ */
+ tmp = build2_loc (loc, PLUS_EXPR, size_type_node, offset,
+ one);
+ gimplify_assign (offset, tmp, &seq);
+
+ /* data[offset_data] = data. */
+ tmp = fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field),
+ token, field, NULL_TREE);
+ tmp = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (tmp), tmp,
+ build2_loc (loc, MULT_EXPR, size_type_node,
+ TYPE_SIZE_UNIT (ptr_type_node), offset));
+ 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, data, &seq);
+
+ /* token.offset_data++ */
+ tmp = build2_loc (loc, PLUS_EXPR, size_type_node, offset,
+ one);
+ gimplify_assign (unshare_expr (offset), tmp, &seq);
+
+ /* sizes[offset] = size. */
+ field = gfc_omp_get_token_sizes (token);
+ offset_field = gfc_omp_get_token_offset (token);
+ offset = fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (offset_field),
+ token, offset_field, NULL_TREE);
+ tmp = fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field),
+ token, field, NULL_TREE);
+ tmp = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (tmp), tmp,
+ build2_loc (loc, MULT_EXPR, size_type_node,
+ TYPE_SIZE_UNIT (ptr_type_node), offset));
+ 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[offset] = (flag == 2) ? 'to' : tkind. */
+ field = gfc_omp_get_token_kinds (token);
+ tmp = fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field),
+ token, field, NULL_TREE);
+ tmp = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (tmp), tmp,
+ build2_loc (loc, MULT_EXPR, size_type_node,
+ TYPE_SIZE_UNIT (short_unsigned_type_node),
+ offset));
+ seq2 = NULL;
+ tmp = force_gimple_operand (tmp, &seq2, true, NULL_TREE);
+ gimple_seq_add_seq (&seq, seq2);
+ cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, flag,
+ build_int_cst (short_integer_type_node,
+ GFC_CLASS_CB_VTABLE));
+ tree tmp2 = fold_build3_loc (loc, COMPONENT_REF,
+ TREE_TYPE (DECL_CHAIN (offset_field)), token,
+ DECL_CHAIN (offset_field), NULL_TREE);
+ tmp2 = build3 (COND_EXPR, short_unsigned_type_node, cond,
+ build_int_cst (short_unsigned_type_node, GOMP_MAP_TO),
+ tmp2);
+ tmp = build_fold_indirect_ref_loc (loc, tmp);
+ gimplify_assign (tmp, tmp2, &seq);
+
+ /* token.offset++ */
+ tmp = build2_loc (loc, PLUS_EXPR, size_type_node, offset,
+ one);
+ gimplify_assign (offset, tmp, &seq);
+
+ /* sizes[offset] = 0 (= bias). */
+ field = gfc_omp_get_token_sizes (token);
+ tmp = fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field),
+ token, field, NULL_TREE);
+ tmp = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (tmp), tmp,
+ build2_loc (loc, MULT_EXPR, size_type_node,
+ TYPE_SIZE_UNIT (ptr_type_node),
+ fold_build3_loc (loc, COMPONENT_REF,
+ TREE_TYPE (offset_field), token,
+ offset_field, NULL_TREE)));
+ 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);
+
+ /* kind[offset] = (token.detach ? GOMP_MAP_DETACH : GOMP_MAP_ATTACH. */
+ field = gfc_omp_get_token_detach (token);
+ tmp2 = fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field), token,
+ field, NULL_TREE);
+ tmp2 = fold_build2_loc (loc, NE_EXPR, boolean_type_node,
+ tmp2, build_zero_cst (TREE_TYPE (tmp2)));
+ tmp2 = build3 (COND_EXPR, short_unsigned_type_node, tmp2,
+ build_int_cst (short_unsigned_type_node, GOMP_MAP_DETACH),
+ build_int_cst (short_unsigned_type_node, GOMP_MAP_ATTACH));
+
+ field = gfc_omp_get_token_kinds (token);
+ tmp = fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field),
+ token, field, NULL_TREE);
+ tmp = build2_loc (loc, POINTER_PLUS_EXPR, TREE_TYPE (tmp), tmp,
+ build2_loc (loc, MULT_EXPR, size_type_node,
+ TYPE_SIZE_UNIT (short_unsigned_type_node),
+ fold_build3_loc (loc, COMPONENT_REF,
+ TREE_TYPE (offset_field), token,
+ offset_field, NULL_TREE)));
+ 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, tmp2, &seq);
+
+ /* token.offset++ */
+ tmp = build2_loc (loc, PLUS_EXPR, size_type_node, offset, one);
+ gimplify_assign (unshare_expr (offset), tmp, &seq);
+
+ /* if (cb_fn)
+ goto return_label
+ cb_fn (...) */
+
+ cont_label = create_artificial_label (loc);
+ gimple_seq_add_stmt (&seq,
+ gimple_build_cond (EQ_EXPR, cb_fn, null_pointer_node,
+ return_label, cont_label));
+ gimple_seq_add_stmt (&seq, gimple_build_label (cont_label));
+ tmp = build_call_expr_loc (loc, build_fold_indirect_ref_loc (loc, cb_fn),
+ 4, build_fold_addr_expr (decl),
+ TREE_OPERAND (token, 0),
+ build_fold_indirect_ref_loc (loc, data),
+ build_int_cst (short_integer_type_node,
+ GFC_CLASS_CALLBACK_DEFAULT_FLAG));
+ gimplify_and_add (tmp, &seq);
+
+ /* return_label:
+ return 0 */
+ gimple_seq_add_stmt (&seq, gimple_build_label (return_label));
+ tmp = fold_build2_loc (loc, MODIFY_EXPR, size_type_node,
+ DECL_RESULT (decl),
+ build_zero_cst (size_type_node));
+ tmp = fold_build1_loc (loc, RETURN_EXPR, void_type_node, tmp);
+ gimplify_and_add (tmp, &seq);
+ }
+
+ pop_gimplify_context (NULL);
+ gimple_set_body (decl, gimple_build_bind (NULL_TREE, seq, NULL));
+ cfun->function_end_locus = loc;
+ cfun->curr_properties |= PROP_gimple_any;
+ pop_cfun ();
+ cgraph_node::add_new_function (decl, true);
+
+ if (old_context)
+ pop_function_context ();
+ current_function_decl = old_context;
+ return decl;
+}
+
+/* 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 *);
+
+/* 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)
+{
+ 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);
+ }
+ 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);
+ else
+ gfc_omp_deep_mapping_comps (is_cnt, loc, tmp, token, tkind,
+ data_array, sizes_array, kinds_array,
+ offset_data, offset, num, seq, ctx);
+ }
+ }
+}
+
+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, 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)
+{
+ static tree map_fn = NULL_TREE;
+ static tree cnt_fn = NULL_TREE;
+ tree tmp;
+ tree type = TREE_TYPE (decl);
+ if (POINTER_TYPE_P (type))
+ type = TREE_TYPE (type);
+ bool poly = gfc_is_polymorphic_nonptr (type);
+ tree end_label = NULL_TREE;
+ tree size = NULL_TREE, elem_len = NULL_TREE;
+
+ 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));
+ }
+ if (POINTER_TYPE_P (TREE_TYPE (decl)))
+ {
+ decl = build_fold_indirect_ref (decl);
+ type = TREE_TYPE (decl);
+ }
+
+ if (!is_cnt && poly && *token == NULL_TREE)
+ {
+ *token = build_decl (input_location, VAR_DECL,
+ create_tmp_var_name ("map_token"),
+ gfc_omp_get_map_token_type (false));
+ gimple_add_tmp_var (*token);
+
+ /* token.data = &data_array[0] */
+ tree field = gfc_omp_get_token_data (*token);
+ tmp = build4 (ARRAY_REF, TREE_TYPE (field), data_array,
+ build_zero_cst (size_type_node), NULL_TREE, NULL_TREE);
+ gimplify_assign (fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field),
+ *token, field, NULL_TREE),
+ build_fold_addr_expr_loc (loc, tmp), seq);
+ /* token.sizes = sizes */
+ field = gfc_omp_get_token_sizes (*token);
+ gimplify_assign (fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field),
+ *token, field, NULL_TREE), sizes_array,
+ seq);
+ /* token.kinds = kinds_array */
+ field = gfc_omp_get_token_kinds (*token);
+ gimplify_assign (fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field),
+ *token, field, NULL_TREE), kinds_array,
+ seq);
+ /* token.flags = tkind */
+ field = gfc_omp_get_token_flags (*token);
+ tmp = build_int_cstu (short_unsigned_type_node, tkind);
+ gimplify_assign (fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field),
+ *token, field, NULL_TREE), tmp, seq);
+ /* token.detach = (ctx == EXIT_DATA) */
+ field = gfc_omp_get_token_detach (*token);
+ gimplify_assign (fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field),
+ *token, field, NULL_TREE),
+ (gimple_omp_target_kind (ctx)
+ == GF_OMP_TARGET_KIND_EXIT_DATA) ? boolean_true_node
+ : boolean_false_node,
+ seq);
+ }
+
+ if (poly && !map_fn)
+ {
+ cnt_fn = build_fold_addr_expr (gfc_omp_gen_deep_map_fn (true));
+ map_fn = build_fold_addr_expr (gfc_omp_gen_deep_map_fn (false));
+ }
+
+ if (is_cnt && do_copy)
+ {
+ tree tmp = fold_build2_loc (input_location, PLUS_EXPR, size_type_node,
+ num, build_int_cst (size_type_node, 1));
+ gimplify_assign (num, tmp, seq);
+ }
+ else if (poly && do_copy)
+ {
+ /* token.offset_data = offset_data */
+ tree field = gfc_omp_get_token_offset_data (*token);
+ tmp = fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field), *token,
+ field, NULL_TREE);
+ gimplify_assign (tmp, offset_data, seq);
+ /* token.offset = offset */
+ field = gfc_omp_get_token_offset (*token);
+ tmp = fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field), *token,
+ field, NULL_TREE);
+ gimplify_assign (tmp, offset_data, seq);
+
+ /* copy vptr + data pointer */
+ /* decl->vptr->callback (omp_map, token, &decl->vptr,
+ GFC_CLASS_CALLBACK_VTABLE_FLAG) */
+ tree cb = build_fold_indirect_ref (gfc_class_vtab_callback_get (decl));
+ tmp = build_fold_addr_expr (gfc_class_vptr_get (decl));
+ tmp
+ = build_call_expr_loc (loc, cb, 4, map_fn,
+ build_fold_addr_expr (*token), tmp,
+ build_int_cst (short_integer_type_node,
+ GFC_CLASS_CALLBACK_VTABLE_FLAG));
+ gimplify_and_add (tmp, seq);
+
+ /* offset_data = token.offset_data */
+ field = gfc_omp_get_token_offset_data (*token);
+ tmp = fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field), *token,
+ field, NULL_TREE);
+ gimplify_assign (tmp, offset_data, seq);
+ /* offset = token.offset */
+ field = gfc_omp_get_token_offset (*token);
+ tmp = fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field), *token,
+ field, NULL_TREE);
+ gimplify_assign (tmp, offset_data, seq);
+
+ tree bytesize = fold_convert (size_type_node,
+ gfc_class_vtab_size_get (decl));
+ tmp = gfc_class_data_get (decl);
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+ {
+ elem_len = bytesize;
+ size = gfc_omp_get_array_size (loc, tmp, seq);
+ bytesize = fold_build2_loc (loc, MULT_EXPR, size_type_node,
+ size, elem_len);
+ tmp = gfc_conv_descriptor_data_get (tmp);
+ }
+
+ gfc_omp_deep_mapping_map (tmp, bytesize, tkind, loc, data_array,
+ sizes_array, kinds_array, offset_data,
+ offset, seq, ctx);
+ }
+ 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 = 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,
+ size, elem_len);
+ tmp = gfc_conv_descriptor_data_get (decl);
+ }
+ else
+ {
+ tmp = decl;
+ bytesize = TYPE_SIZE_UNIT (TREE_TYPE (decl));
+ }
+ gfc_omp_deep_mapping_map (tmp, bytesize, tkind, loc, data_array,
+ sizes_array, kinds_array, offset_data,
+ offset, seq, ctx);
+ }
+
+ /* Handle allocatable components. */
+ if (!is_cnt && poly)
+ {
+ /* token.offset_data = offset_data */
+ tree field = gfc_omp_get_token_offset_data (*token);
+ tmp = fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field), *token,
+ field, NULL_TREE);
+ gimplify_assign (tmp, offset_data, seq);
+ /* token.offset = offset */
+ field = gfc_omp_get_token_offset (*token);
+ tmp = fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field), *token,
+ field, NULL_TREE);
+ gimplify_assign (unshare_expr (tmp), offset_data, seq);
+ }
+ if (poly)
+ {
+ tree cb = build_fold_indirect_ref (gfc_class_vtab_callback_get (decl));
+ tmp = gfc_class_data_get (decl);
+ gimple_seq seq2 = NULL;
+ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)))
+ {
+ if (elem_len == NULL_TREE)
+ {
+ elem_len = fold_convert (size_type_node,
+ gfc_class_vtab_size_get (decl));
+ size = gfc_omp_get_array_size (loc, tmp, seq);
+ }
+ tmp = gfc_conv_descriptor_data_get (tmp);
+ tmp = gfc_omp_elmental_loop (loc, tmp, size, elem_len, seq, &seq2);
+ }
+ tree flag = build_int_cst (short_integer_type_node,
+ GFC_CLASS_CALLBACK_DEFAULT_FLAG);
+ tmp = build_call_expr_loc (loc, cb, 4, is_cnt ? cnt_fn : map_fn,
+ is_cnt ? null_pointer_node
+ : build_fold_addr_expr (*token),
+ tmp, flag);
+ gimplify_and_add (tmp, seq);
+ gimple_seq_add_seq (seq, seq2);
+ }
+ if (!is_cnt && poly)
+ {
+ /* offset_data = token.offset_data */
+ tree field = gfc_omp_get_token_offset_data (*token);
+ tmp = fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field), *token,
+ field, NULL_TREE);
+ gimplify_assign (unshare_expr (offset_data), tmp, seq);
+ /* offset = token.offset */
+ field = gfc_omp_get_token_offset (*token);
+ tmp = fold_build3_loc (loc, COMPONENT_REF, TREE_TYPE (field), *token,
+ field, NULL_TREE);
+ gimplify_assign (unshare_expr (offset_data), tmp, seq);
+ }
+
+ /* Get field decl. */
+ if (!poly)
+ {
+ 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 = 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 (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);
+ 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_FIRSTPRIVATE:
+ return true;
+ case GOMP_MAP_ALLOC:
+ 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_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_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);
+ if (decl == NULL_TREE)
+ 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 (input_location, 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;
+
+ /* 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);
+ 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);
+ /* Double: Map + pointer assign. */
+ if (is_cnt)
+ gimplify_assign (num,
+ fold_build2_loc (input_location, 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.'
@@ -2389,6 +3727,18 @@ gfc_trans_omp_array_section (stmtblock_t *block, gfc_omp_namelist *n,
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)));
@@ -3208,7 +4558,8 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
/* We have to check for n->sym->attr.dimension because
of scalar coarrays. */
- if (n->sym->attr.pointer && n->sym->attr.dimension)
+ if ((n->sym->attr.pointer || n->sym->attr.allocatable)
+ && n->sym->attr.dimension)
{
stmtblock_t cond_block;
tree size
@@ -3284,13 +4635,40 @@ 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;
+ 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
@@ -3356,6 +4734,31 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
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
@@ -3394,7 +4797,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)
{
tree data, size;
@@ -3428,6 +4831,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)
@@ -3499,6 +4918,22 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
{
node2 = node;
node = desc_node; /* Put first. */
+ 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 (node2);
+ tree var = gfc_create_var (TREE_TYPE (tmp),
+ NULL);
+ gfc_add_modify_loc (input_location, block,
+ var, tmp);
+ OMP_CLAUSE_SIZE (node2) = var;
+ gfc_allocate_lang_decl (var);
+ GFC_DECL_SAVED_DESCRIPTOR (var) = inner;
+ }
}
node3 = build_omp_clause (input_location,
OMP_CLAUSE_MAP);
@@ -1449,8 +1449,16 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT
: GFC_ARRAY_ASSUMED_SHAPE;
else if (as->type == AS_ASSUMED_RANK)
- akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_CONT
- : GFC_ARRAY_ASSUMED_RANK;
+ {
+ if (akind == GFC_ARRAY_ALLOCATABLE)
+ akind = GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE;
+ else if (akind == GFC_ARRAY_POINTER || akind == GFC_ARRAY_POINTER_CONT)
+ akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_POINTER_CONT
+ : GFC_ARRAY_ASSUMED_RANK_POINTER;
+ else
+ akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_CONT
+ : GFC_ARRAY_ASSUMED_RANK;
+ }
return gfc_get_array_type_bounds (type, as->rank == -1
? GFC_MAX_DIMENSIONS : as->rank,
corank, lbound, ubound, 0, akind,
@@ -2711,9 +2719,10 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
}
if (derived->components
- && derived->components->ts.type == BT_DERIVED
- && strcmp (derived->components->name, "_data") == 0
- && derived->components->ts.u.derived->attr.unlimited_polymorphic)
+ && derived->components->ts.type == BT_DERIVED
+ && startswith (derived->name, "__class")
+ && strcmp (derived->components->name, "_data") == 0
+ && derived->components->ts.u.derived->attr.unlimited_polymorphic)
unlimited_entity = true;
/* Go through the derived type components, building them as
@@ -2812,16 +2821,26 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
if (c->attr.pointer || c->attr.allocatable || c->attr.pdt_array)
{
enum gfc_array_kind akind;
- if (c->attr.pointer)
+ bool is_ptr = ((c == derived->components
+ && derived->components->ts.type == BT_DERIVED
+ && startswith (derived->name, "__class")
+ && (strcmp (derived->components->name, "_data")
+ == 0))
+ ? c->attr.class_pointer : c->attr.pointer);
+ if (is_ptr)
akind = c->attr.contiguous ? GFC_ARRAY_POINTER_CONT
: GFC_ARRAY_POINTER;
- else
+ else if (c->attr.allocatable)
akind = GFC_ARRAY_ALLOCATABLE;
+ else if (c->as->type == AS_ASSUMED_RANK)
+ akind = GFC_ARRAY_ASSUMED_RANK;
+ else
+ /* FIXME – see PR fortran/104651. */
+ akind = GFC_ARRAY_ASSUMED_SHAPE;
/* Pointers to arrays aren't actually pointer types. The
descriptors are separate, but the data is common. */
field_type = gfc_build_array_type (field_type, c->as, akind,
- !c->attr.target
- && !c->attr.pointer,
+ !c->attr.target && !is_ptr,
c->attr.contiguous,
codimen);
}
@@ -3472,15 +3491,22 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
t = fold_build_pointer_plus (t, data_off);
t = build1 (NOP_EXPR, build_pointer_type (ptr_type_node), t);
info->data_location = build1 (INDIRECT_REF, ptr_type_node, t);
- if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
+ if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE)
info->allocated = build2 (NE_EXPR, logical_type_node,
info->data_location, null_pointer_node);
else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
- || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_POINTER
+ || (GFC_TYPE_ARRAY_AKIND (type)
+ == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT))
info->associated = build2 (NE_EXPR, logical_type_node,
info->data_location, null_pointer_node);
if ((GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK
- || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT)
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_POINTER
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT)
&& dwarf_version >= 5)
{
rank = 1;
@@ -435,6 +435,7 @@ tree gfc_class_vtab_size_get (tree);
tree gfc_class_vtab_def_init_get (tree);
tree gfc_class_vtab_copy_get (tree);
tree gfc_class_vtab_final_get (tree);
+tree gfc_class_vtab_callback_get (tree);
/* Get an accessor to the vtab's * field, when a vptr handle is present. */
tree gfc_vptr_hash_get (tree);
tree gfc_vptr_size_get (tree);
@@ -816,6 +817,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);
@@ -986,6 +991,9 @@ enum gfc_array_kind
GFC_ARRAY_ASSUMED_SHAPE_CONT,
GFC_ARRAY_ASSUMED_RANK,
GFC_ARRAY_ASSUMED_RANK_CONT,
+ GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE,
+ GFC_ARRAY_ASSUMED_RANK_POINTER,
+ GFC_ARRAY_ASSUMED_RANK_POINTER_CONT,
GFC_ARRAY_ALLOCATABLE,
GFC_ARRAY_POINTER,
GFC_ARRAY_POINTER_CONT
@@ -84,6 +84,10 @@ extern enum omp_clause_default_kind lhd_omp_predetermined_sharing (tree);
extern enum omp_clause_defaultmap_kind lhd_omp_predetermined_mapping (tree);
extern tree lhd_omp_assignment (tree, tree, tree);
extern void lhd_omp_finish_clause (tree, gimple_seq *, bool);
+extern bool lhd_omp_deep_mapping_p (const gimple *, tree);
+extern tree lhd_omp_deep_mapping_cnt (const gimple *, tree, gimple_seq *);
+extern void lhd_omp_deep_mapping (const gimple *, tree, unsigned HOST_WIDE_INT,
+ tree, tree, tree, tree, tree, gimple_seq *);
struct gimplify_omp_ctx;
extern void lhd_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *,
tree);
@@ -270,6 +274,9 @@ extern tree lhd_unit_size_without_reusable_padding (tree);
#define LANG_HOOKS_OMP_CLAUSE_LINEAR_CTOR NULL
#define LANG_HOOKS_OMP_CLAUSE_DTOR hook_tree_tree_tree_null
#define LANG_HOOKS_OMP_FINISH_CLAUSE lhd_omp_finish_clause
+#define LANG_HOOKS_OMP_DEEP_MAPPING_P lhd_omp_deep_mapping_p
+#define LANG_HOOKS_OMP_DEEP_MAPPING_CNT lhd_omp_deep_mapping_cnt
+#define LANG_HOOKS_OMP_DEEP_MAPPING lhd_omp_deep_mapping
#define LANG_HOOKS_OMP_ALLOCATABLE_P hook_bool_tree_false
#define LANG_HOOKS_OMP_SCALAR_P lhd_omp_scalar_p
#define LANG_HOOKS_OMP_SCALAR_TARGET_P hook_bool_tree_false
@@ -303,6 +310,9 @@ extern tree lhd_unit_size_without_reusable_padding (tree);
LANG_HOOKS_OMP_CLAUSE_LINEAR_CTOR, \
LANG_HOOKS_OMP_CLAUSE_DTOR, \
LANG_HOOKS_OMP_FINISH_CLAUSE, \
+ LANG_HOOKS_OMP_DEEP_MAPPING_P, \
+ LANG_HOOKS_OMP_DEEP_MAPPING_CNT, \
+ LANG_HOOKS_OMP_DEEP_MAPPING, \
LANG_HOOKS_OMP_ALLOCATABLE_P, \
LANG_HOOKS_OMP_SCALAR_P, \
LANG_HOOKS_OMP_SCALAR_TARGET_P, \
@@ -634,6 +634,30 @@ lhd_omp_finish_clause (tree, gimple_seq *, bool)
{
}
+/* Returns true when additional mappings for a decl are needed. */
+
+bool
+lhd_omp_deep_mapping_p (const gimple *, tree)
+{
+ return false;
+}
+
+/* Returns number of additional mappings for a decl. */
+
+tree
+lhd_omp_deep_mapping_cnt (const gimple *, tree, gimple_seq *)
+{
+ return NULL_TREE;
+}
+
+/* Do the additional mappings. */
+
+void
+lhd_omp_deep_mapping (const gimple *, tree, unsigned HOST_WIDE_INT, tree, tree,
+ tree, tree, tree, gimple_seq *)
+{
+}
+
/* Return true if DECL is a scalar variable (for the purpose of
implicit firstprivatization & mapping). Only if alloc_ptr_ok
are allocatables and pointers accepted. */
@@ -306,6 +306,21 @@ struct lang_hooks_for_decls
/* Do language specific checking on an implicitly determined clause. */
void (*omp_finish_clause) (tree clause, gimple_seq *pre_p, bool);
+ /* Additional language-specific mappings for a decl; returns true
+ if those may occur. */
+ bool (*omp_deep_mapping_p) (const gimple *ctx_stmt, tree clause);
+
+ /* Additional language-specific mappings for a decl; returns the
+ number of additional mappings needed. */
+ tree (*omp_deep_mapping_cnt) (const gimple *ctx_stmt, tree clause,
+ gimple_seq *seq);
+
+ /* Do the actual additional language-specific mappings for a decl. */
+ void (*omp_deep_mapping) (const gimple *stmt, tree clause,
+ unsigned HOST_WIDE_INT tkind,
+ tree data, tree sizes, tree kinds,
+ tree offset_data, tree offset, gimple_seq *seq);
+
/* Return true if DECL is an allocatable variable (for the purpose of
implicit mapping). */
bool (*omp_allocatable_p) (tree decl);
@@ -9786,8 +9786,9 @@ expand_omp_target (struct omp_region *region)
/* We're ignoring the subcode because we're
effectively doing a STRIP_NOPS. */
- if (TREE_CODE (arg) == ADDR_EXPR
- && TREE_OPERAND (arg, 0) == sender)
+ if ((TREE_CODE (arg) == ADDR_EXPR
+ && TREE_OPERAND (arg, 0) == sender)
+ || arg == sender)
{
tgtcopy_stmt = stmt;
break;
@@ -10105,7 +10106,7 @@ expand_omp_target (struct omp_region *region)
t3 = t2;
t4 = t2;
}
- else
+ else if (TREE_VEC_LENGTH (t) == 3)
{
t1 = TYPE_MAX_VALUE (TYPE_DOMAIN (TREE_TYPE (TREE_VEC_ELT (t, 1))));
t1 = size_binop (PLUS_EXPR, t1, size_int (1));
@@ -10113,6 +10114,17 @@ expand_omp_target (struct omp_region *region)
t3 = build_fold_addr_expr (TREE_VEC_ELT (t, 1));
t4 = build_fold_addr_expr (TREE_VEC_ELT (t, 2));
}
+ else
+ {
+ t1 = force_gimple_operand_gsi (&gsi, TREE_VEC_ELT (t, 3), true, NULL_TREE,
+ true, GSI_SAME_STMT);
+ t2 = force_gimple_operand_gsi (&gsi, TREE_VEC_ELT (t, 0), true, NULL_TREE,
+ true, GSI_SAME_STMT);
+ t3 = force_gimple_operand_gsi (&gsi, TREE_VEC_ELT (t, 1), true, NULL_TREE,
+ true, GSI_SAME_STMT);
+ t4 = force_gimple_operand_gsi (&gsi, TREE_VEC_ELT (t, 2), true, NULL_TREE,
+ true, GSI_SAME_STMT);
+ }
gimple *g;
bool tagging = false;
@@ -764,7 +764,10 @@ static tree
build_sender_ref (splay_tree_key key, omp_context *ctx)
{
tree field = lookup_sfield (key, ctx);
- return omp_build_component_ref (ctx->sender_decl, field);
+ tree tmp = ctx->sender_decl;
+ if (POINTER_TYPE_P (TREE_TYPE (tmp)))
+ tmp = build_fold_indirect_ref (tmp);
+ return omp_build_component_ref (tmp, field);
}
static tree
@@ -1135,7 +1138,9 @@ fixup_child_record_type (omp_context *ctx)
type = build_qualified_type (type, TYPE_QUAL_CONST);
TREE_TYPE (ctx->receiver_decl)
- = build_qualified_type (build_reference_type (type), TYPE_QUAL_RESTRICT);
+ = build_qualified_type (flexible_array_type_p (type)
+ ? build_pointer_type (type)
+ : build_reference_type (type), TYPE_QUAL_RESTRICT);
}
/* Instantiate decls as necessary in CTX to satisfy the data sharing
@@ -1146,6 +1151,7 @@ scan_sharing_clauses (tree clauses, omp_context *ctx)
{
tree c, decl;
bool scan_array_reductions = false;
+ bool flex_array_ptr = false;
for (c = clauses; c; c = OMP_CLAUSE_CHAIN (c))
if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_ALLOCATE
@@ -1526,6 +1532,8 @@ scan_sharing_clauses (tree clauses, omp_context *ctx)
&& !OMP_CLAUSE_MAP_ZERO_BIAS_ARRAY_SECTION (c))
break;
}
+ if (!flex_array_ptr)
+ flex_array_ptr = lang_hooks.decls.omp_deep_mapping_p (ctx->stmt, c);
if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_MAP
&& DECL_P (decl)
&& (OMP_CLAUSE_MAP_KIND (c) == GOMP_MAP_ATTACH
@@ -1930,6 +1938,18 @@ scan_sharing_clauses (tree clauses, omp_context *ctx)
&& OMP_CLAUSE_LINEAR_GIMPLE_SEQ (c))
scan_omp (&OMP_CLAUSE_LINEAR_GIMPLE_SEQ (c), ctx);
}
+ if (flex_array_ptr)
+ {
+ tree field = build_range_type (size_type_node,
+ build_int_cstu (size_type_node, 0),
+ NULL_TREE);
+ field = build_array_type (ptr_type_node, field);
+ field = build_decl (UNKNOWN_LOCATION, FIELD_DECL, NULL_TREE, field);
+ SET_DECL_ALIGN (field, TYPE_ALIGN (ptr_type_node));
+ DECL_CONTEXT (field) = ctx->record_type;
+ DECL_CHAIN (field) = TYPE_FIELDS (ctx->record_type);
+ TYPE_FIELDS (ctx->record_type) = field;
+ }
}
/* Create a new name for omp child function. Returns an identifier. */
@@ -12540,6 +12560,11 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
unsigned int map_cnt = 0;
tree in_reduction_clauses = NULL_TREE;
+ tree deep_map_cnt = NULL_TREE;
+ tree deep_map_data = NULL_TREE;
+ tree deep_map_offset_data = NULL_TREE;
+ tree deep_map_offset = NULL_TREE;
+
offloaded = is_gimple_omp_offloaded (stmt);
switch (gimple_omp_target_kind (stmt))
{
@@ -12613,6 +12638,8 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
push_gimplify_context ();
fplist = NULL;
+ ilist = NULL;
+ olist = NULL;
for (c = clauses; c ; c = OMP_CLAUSE_CHAIN (c))
switch (OMP_CLAUSE_CODE (c))
{
@@ -12666,6 +12693,16 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
case OMP_CLAUSE_FROM:
oacc_firstprivate:
var = OMP_CLAUSE_DECL (c);
+ {
+ tree extra = lang_hooks.decls.omp_deep_mapping_cnt (stmt, c, &ilist);
+ if (extra != NULL_TREE && deep_map_cnt != NULL_TREE)
+ deep_map_cnt = fold_build2_loc (OMP_CLAUSE_LOCATION (c), PLUS_EXPR,
+ size_type_node, deep_map_cnt,
+ extra);
+ else if (extra != NULL_TREE)
+ deep_map_cnt = extra;
+ }
+
if (!DECL_P (var))
{
if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_MAP
@@ -12893,18 +12930,31 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
record_vars_into (gimple_bind_vars (tgt_bind), child_fn);
}
- olist = NULL;
- ilist = NULL;
if (ctx->record_type)
{
+ if (deep_map_cnt && TREE_CODE (deep_map_cnt) == INTEGER_CST)
+ /* map_cnt = map_cnt + tree_to_hwi (deep_map_cnt); */
+ /* deep_map_cnt = NULL_TREE; */
+ gcc_unreachable ();
+ else if (deep_map_cnt)
+ {
+ gcc_assert (flexible_array_type_p (ctx->record_type));
+ tree n = create_tmp_var_raw (size_type_node, "nn_map");
+ gimple_add_tmp_var (n);
+ gimplify_assign (n, deep_map_cnt, &ilist);
+ deep_map_cnt = n;
+ }
ctx->sender_decl
- = create_tmp_var (ctx->record_type, ".omp_data_arr");
+ = create_tmp_var (deep_map_cnt ? build_pointer_type (ctx->record_type)
+ : ctx->record_type, ".omp_data_arr");
DECL_NAMELESS (ctx->sender_decl) = 1;
TREE_ADDRESSABLE (ctx->sender_decl) = 1;
- t = make_tree_vec (3);
+ t = make_tree_vec (deep_map_cnt ? 4 : 3);
TREE_VEC_ELT (t, 0) = ctx->sender_decl;
TREE_VEC_ELT (t, 1)
- = create_tmp_var (build_array_type_nelts (size_type_node, map_cnt),
+ = create_tmp_var (deep_map_cnt
+ ? build_pointer_type (size_type_node)
+ : build_array_type_nelts (size_type_node, map_cnt),
".omp_data_sizes");
DECL_NAMELESS (TREE_VEC_ELT (t, 1)) = 1;
TREE_ADDRESSABLE (TREE_VEC_ELT (t, 1)) = 1;
@@ -12912,13 +12962,65 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
tree tkind_type = short_unsigned_type_node;
int talign_shift = 8;
TREE_VEC_ELT (t, 2)
- = create_tmp_var (build_array_type_nelts (tkind_type, map_cnt),
+ = create_tmp_var (deep_map_cnt
+ ? build_pointer_type (tkind_type)
+ : build_array_type_nelts (tkind_type, map_cnt),
".omp_data_kinds");
DECL_NAMELESS (TREE_VEC_ELT (t, 2)) = 1;
TREE_ADDRESSABLE (TREE_VEC_ELT (t, 2)) = 1;
TREE_STATIC (TREE_VEC_ELT (t, 2)) = 1;
gimple_omp_target_set_data_arg (stmt, t);
+ if (deep_map_cnt)
+ {
+ tree tmp, size;
+ size = create_tmp_var (size_type_node, NULL);
+ DECL_NAMELESS (size) = 1;
+ gimplify_assign (size,
+ fold_build2_loc (UNKNOWN_LOCATION, PLUS_EXPR,
+ size_type_node, deep_map_cnt,
+ build_int_cst (size_type_node,
+ map_cnt)), &ilist);
+ TREE_VEC_ELT (t, 3) = size;
+
+ tree call = builtin_decl_explicit (BUILT_IN_MALLOC);
+ size = fold_build2_loc (UNKNOWN_LOCATION, MULT_EXPR,
+ size_type_node, deep_map_cnt,
+ TYPE_SIZE_UNIT (ptr_type_node));
+ size = fold_build2_loc (UNKNOWN_LOCATION, PLUS_EXPR,
+ size_type_node, size,
+ TYPE_SIZE_UNIT (ctx->record_type));
+ tmp = build_call_expr_loc (input_location, call, 1, size);
+ gimplify_assign (ctx->sender_decl, tmp, &ilist);
+
+ size = fold_build2_loc (UNKNOWN_LOCATION, MULT_EXPR,
+ size_type_node, TREE_VEC_ELT (t, 3),
+ TYPE_SIZE_UNIT (size_type_node));
+ tmp = build_call_expr_loc (input_location, call, 1, size);
+ gimplify_assign (TREE_VEC_ELT (t, 1), tmp, &ilist);
+
+ size = fold_build2_loc (UNKNOWN_LOCATION, MULT_EXPR,
+ size_type_node, TREE_VEC_ELT (t, 3),
+ TYPE_SIZE_UNIT (tkind_type));
+ tmp = build_call_expr_loc (input_location, call, 1, size);
+ gimplify_assign (TREE_VEC_ELT (t, 2), tmp, &ilist);
+ tree field = TYPE_FIELDS (TREE_TYPE (TREE_TYPE (ctx->sender_decl)));
+ for ( ; DECL_CHAIN (field) != NULL_TREE; field = DECL_CHAIN (field))
+ ;
+ gcc_assert (TREE_CODE (TREE_TYPE (field)));
+ tmp = build_fold_indirect_ref (ctx->sender_decl);
+ deep_map_data = omp_build_component_ref (tmp, field);
+ deep_map_offset_data = create_tmp_var_raw (size_type_node,
+ "map_offset_data");
+ deep_map_offset = create_tmp_var_raw (size_type_node, "map_offset");
+ gimple_add_tmp_var (deep_map_offset_data);
+ gimple_add_tmp_var (deep_map_offset);
+ gimplify_assign (deep_map_offset_data, build_int_cst (size_type_node,
+ 0), &ilist);
+ gimplify_assign (deep_map_offset, build_int_cst (size_type_node,
+ map_cnt), &ilist);
+ }
+
vec<constructor_elt, va_gc> *vsize;
vec<constructor_elt, va_gc> *vkind;
vec_alloc (vsize, map_cnt);
@@ -12945,6 +13047,24 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
|| (OMP_CLAUSE_MAP_KIND (c)
== GOMP_MAP_FIRSTPRIVATE_REFERENCE)))
break;
+ if (deep_map_cnt)
+ {
+ unsigned HOST_WIDE_INT tkind2;
+ switch (OMP_CLAUSE_CODE (c))
+ {
+ case OMP_CLAUSE_MAP: tkind2 = OMP_CLAUSE_MAP_KIND (c); break;
+ case OMP_CLAUSE_FIRSTPRIVATE: tkind2 = GOMP_MAP_TO; break;
+ case OMP_CLAUSE_TO: tkind2 = GOMP_MAP_TO; break;
+ case OMP_CLAUSE_FROM: tkind2 = GOMP_MAP_FROM; break;
+ default: gcc_unreachable ();
+ }
+ lang_hooks.decls.omp_deep_mapping (stmt, c, tkind2,
+ deep_map_data,
+ TREE_VEC_ELT (t, 1),
+ TREE_VEC_ELT (t, 2),
+ deep_map_offset_data,
+ deep_map_offset, &ilist);
+ }
if (!DECL_P (ovar))
{
if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_MAP
@@ -13420,23 +13540,65 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
gcc_assert (map_idx == map_cnt);
- DECL_INITIAL (TREE_VEC_ELT (t, 1))
- = build_constructor (TREE_TYPE (TREE_VEC_ELT (t, 1)), vsize);
- DECL_INITIAL (TREE_VEC_ELT (t, 2))
- = build_constructor (TREE_TYPE (TREE_VEC_ELT (t, 2)), vkind);
+ if (!deep_map_cnt)
+ {
+ DECL_INITIAL (TREE_VEC_ELT (t, 1))
+ = build_constructor (TREE_TYPE (TREE_VEC_ELT (t, 1)), vsize);
+ DECL_INITIAL (TREE_VEC_ELT (t, 2))
+ = build_constructor (TREE_TYPE (TREE_VEC_ELT (t, 2)), vkind);
+ }
for (int i = 1; i <= 2; i++)
- if (!TREE_STATIC (TREE_VEC_ELT (t, i)))
+ if (deep_map_cnt || !TREE_STATIC (TREE_VEC_ELT (t, i)))
{
+ tree tmp = TREE_VEC_ELT (t, i);
+ if (deep_map_cnt)
+ {
+ const char *prefix = (i == 1 ? ".omp_data_sizes0"
+ : ".omp_data_kinds0");
+ tree type = (i == 1) ? size_type_node : tkind_type;
+ type = build_array_type_nelts (type, map_cnt);
+ tree var = create_tmp_var (type, prefix);
+ DECL_NAMELESS (var) = 1;
+ TREE_ADDRESSABLE (var) = 1;
+ TREE_STATIC (var) = TREE_STATIC (tmp);
+ DECL_INITIAL (var) = build_constructor (type, i == 1
+ ? vsize : vkind);
+ tmp = var;
+ TREE_STATIC (TREE_VEC_ELT (t, i)) = 0;
+ }
+
gimple_seq initlist = NULL;
- force_gimple_operand (build1 (DECL_EXPR, void_type_node,
- TREE_VEC_ELT (t, i)),
+ force_gimple_operand (build1 (DECL_EXPR, void_type_node, tmp),
&initlist, true, NULL_TREE);
gimple_seq_add_seq (&ilist, initlist);
- tree clobber = build_clobber (TREE_TYPE (TREE_VEC_ELT (t, i)));
- gimple_seq_add_stmt (&olist,
- gimple_build_assign (TREE_VEC_ELT (t, i),
- clobber));
+ if (deep_map_cnt)
+ {
+ tree tmp2;
+ tree call = builtin_decl_explicit (BUILT_IN_MEMCPY);
+ tmp2 = TYPE_SIZE_UNIT (TREE_TYPE (tmp));
+ call = build_call_expr_loc (input_location, call, 3,
+ TREE_VEC_ELT (t, i),
+ build_fold_addr_expr (tmp), tmp2);
+ gimplify_and_add (call, &ilist);
+ }
+
+ if (!TREE_STATIC (tmp))
+ {
+ tree clobber = build_clobber (TREE_TYPE (tmp));
+ gimple_seq_add_stmt (&olist,
+ gimple_build_assign (tmp, clobber));
+ }
+ if (deep_map_cnt)
+ {
+ tmp = TREE_VEC_ELT (t, i);
+ tree call = builtin_decl_explicit (BUILT_IN_FREE);
+ call = build_call_expr_loc (input_location, call, 1, tmp);
+ gimplify_and_add (call, &olist);
+ tree clobber = build_clobber (TREE_TYPE (tmp));
+ gimple_seq_add_stmt (&olist,
+ gimple_build_assign (tmp, clobber));
+ }
}
else if (omp_maybe_offloaded_ctx (ctx->outer))
{
@@ -13456,7 +13618,18 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
}
}
- tree clobber = build_clobber (ctx->record_type);
+ if (deep_map_cnt)
+ {
+ tree call = builtin_decl_explicit (BUILT_IN_FREE);
+ call = build_call_expr_loc (input_location, call, 1,
+ TREE_VEC_ELT (t, 0));
+ gimplify_and_add (call, &olist);
+
+ gimplify_expr (&TREE_VEC_ELT (t, 1), &ilist, NULL, is_gimple_val,
+ fb_rvalue);
+ }
+
+ tree clobber = build_clobber (TREE_TYPE (ctx->sender_decl));
gimple_seq_add_stmt (&olist, gimple_build_assign (ctx->sender_decl,
clobber));
}
@@ -13469,11 +13642,16 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
if (offloaded
&& ctx->record_type)
{
- t = build_fold_addr_expr_loc (loc, ctx->sender_decl);
+ t = ctx->sender_decl;
+ if (!deep_map_cnt)
+ t = build_fold_addr_expr_loc (loc, t);
/* fixup_child_record_type might have changed receiver_decl's type. */
t = fold_convert_loc (loc, TREE_TYPE (ctx->receiver_decl), t);
- gimple_seq_add_stmt (&new_body,
- gimple_build_assign (ctx->receiver_decl, t));
+ if (!AGGREGATE_TYPE_P (TREE_TYPE (ctx->sender_decl)))
+ gimplify_assign (ctx->receiver_decl, t, &new_body);
+ else
+ gimple_seq_add_stmt (&new_body,
+ gimple_build_assign (ctx->receiver_decl, t));
}
gimple_seq_add_seq (&new_body, fplist);
@@ -20,4 +20,4 @@ end
! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) &\\(.yyy.\[0-9\]+\\)\\\[0\\\];" 1 "original" } }
! { dg-final { scan-tree-dump-times "parm.\[0-9\]+.data = \\(void .\\) &\\(.yyy.\[0-9\]+\\)\\\[D.\[0-9\]+ \\* 4\\\];" 1 "original" } }
-! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = parm.\[0-9\]+.data;\[^;]+ptr\[1-4\] = D.\[0-9\]+;" 4 "original" } }
+! { dg-final { scan-tree-dump-times "ptr\[1-4\] = parm.\[0-9\]+.data;" 4 "original" } }
@@ -8,4 +8,4 @@
class(*), allocatable :: var
end
-! { dg-final { scan-tree-dump "static struct __vtype__STAR __vtab__STAR = {._hash=0, ._size=., ._extends=0B, ._def_init=0B, ._copy=0B, ._final=0B, ._deallocate=0B};" "original" } }
+! { dg-final { scan-tree-dump "static struct __vtype__STAR __vtab__STAR = {._hash=0, ._size=8, ._extends=0B, ._def_init=0B, ._copy=0B, ._final=0B, ._deallocate=0B, ._callback=0B};" "original" } }
@@ -5,11 +5,8 @@ type t
end type t
type(t), allocatable :: b(:)
-! { dg-note {'b' declared here} {} { target *-*-* } .-1 }
!$acc update host(b)
-! { dg-warning {'b\.dim\[0\]\.ubound' is used uninitialized} {} { target *-*-* } .-1 }
-! { dg-warning {'b\.dim\[0\]\.lbound' is used uninitialized} {} { target *-*-* } .-2 }
!$acc update host(b(:))
!$acc update host(b(1)%A)
!$acc update host(b(1)%A(:,:))
@@ -7,10 +7,7 @@
program p
character :: c(2) = 'a'
character, allocatable :: z(:)
- ! { dg-note {'z' declared here} {} { target *-*-* } .-1 }
!$acc parallel
- ! { dg-warning {'z\.dim\[0\]\.ubound' is used uninitialized} {} { target *-*-* } .-1 }
- ! { dg-warning {'z\.dim\[0\]\.lbound' is used uninitialized} {} { target *-*-* } .-2 }
!$omp target
z = c
!$acc end parallel
@@ -10,5 +10,5 @@ type sct
end type
type(sct) var
-!$omp target enter data map(to:var) ! { dg-error "allocatable components is not permitted in map clause" }
+!$omp target enter data map(to:var)
end
new file mode 100644
@@ -0,0 +1,53 @@
+implicit none
+type t
+ integer, allocatable :: a, b(:)
+end type t
+type(t) :: x, y, z
+integer :: i
+
+!$omp target map(to: x)
+ if (allocated(x%a)) stop 1
+ if (allocated(x%b)) stop 2
+!$omp end target
+
+allocate(x%a, x%b(-4:6))
+x%b(:) = [(i, i=-4,6)]
+
+!$omp target map(to: x)
+ if (.not. allocated(x%a)) stop 3
+ if (.not. allocated(x%b)) stop 4
+ if (lbound(x%b,1) /= -4) stop 5
+ if (ubound(x%b,1) /= 6) stop 6
+ if (any (x%b /= [(i, i=-4,6)])) stop 7
+!$omp end target
+
+
+! The following only works with arrays due to
+! PR fortran/96668
+
+!$omp target enter data map(to: y, z)
+
+!$omp target map(to: y, z)
+ if (allocated(y%b)) stop 8
+ if (allocated(z%b)) stop 9
+!$omp end target
+
+allocate(y%b(5), z%b(3))
+y%b = 42
+z%b = 99
+
+! (implicitly) 'tofrom' mapped
+! Planned for OpenMP 6.0 (but common extension)
+! OpenMP <= 5.0 unclear
+!$omp target map(to: y)
+ if (.not.allocated(y%b)) stop 10
+ if (any (y%b /= 42)) stop 11
+!$omp end target
+
+! always map: OpenMP 5.1 (clarified)
+!$omp target map(always, tofrom: z)
+ if (.not.allocated(z%b)) stop 12
+ if (any (z%b /= 99)) stop 13
+!$omp end target
+
+end
new file mode 100644
@@ -0,0 +1,121 @@
+type t2
+ integer x, y, z
+end type t2
+type t
+ integer, allocatable :: A
+ integer, allocatable :: B(:)
+ type(t2), allocatable :: C
+ type(t2), allocatable :: D(:,:)
+end type t
+
+type t3
+ type(t) :: Q
+ type(t) :: R(5)
+end type
+
+type(t) :: var, var2
+type(t3) :: var3, var4
+
+! --------------------------------------
+! Assign + allocate
+var%A = 45
+var%B = [1,2,3]
+var%C = t2(6,5,4)
+var%D = reshape([t2(1,2,3), t2(4,5,6), t2(11,12,13), t2(14,15,16)], [2,2])
+
+! Assign + allocate
+var2%A = 145
+var2%B = [991,992,993]
+var2%C = t2(996,995,994)
+var2%D = reshape([t2(199,299,399), t2(499,599,699), t2(1199,1299,1399), t2(1499,1599,1699)], [2,2])
+
+
+!$omp target map(to: var) map(tofrom: var2)
+ call foo(var, var2)
+!$omp end target
+
+if (var2%A /= 45) stop 9
+if (any (var2%B /= [1,2,3])) stop 10
+if (var2%C%x /= 6) stop 11
+if (var2%C%y /= 5) stop 11
+if (var2%C%z /= 4) stop 11
+if (any (var2%D(:,:)%x /= reshape([1, 4, 11, 14], [2,2]))) stop 12
+if (any (var2%D(:,:)%y /= reshape([2, 5, 12, 15], [2,2]))) stop 12
+if (any (var2%D(:,:)%z /= reshape([3, 6, 13, 16], [2,2]))) stop 12
+
+! --------------------------------------
+! Assign + allocate
+var3%Q%A = 45
+var3%Q%B = [1,2,3]
+var3%Q%C = t2(6,5,4)
+var3%Q%D = reshape([t2(1,2,3), t2(4,5,6), t2(11,12,13), t2(14,15,16)], [2,2])
+
+var3%R(2)%A = 45
+var3%R(2)%B = [1,2,3]
+var3%R(2)%C = t2(6,5,4)
+var3%R(2)%D = reshape([t2(1,2,3), t2(4,5,6), t2(11,12,13), t2(14,15,16)], [2,2])
+
+! Assign + allocate
+var4%Q%A = 145
+var4%Q%B = [991,992,993]
+var4%Q%C = t2(996,995,994)
+var4%Q%D = reshape([t2(199,299,399), t2(499,599,699), t2(1199,1299,1399), t2(1499,1599,1699)], [2,2])
+
+var4%R(3)%A = 145
+var4%R(3)%B = [991,992,993]
+var4%R(3)%C = t2(996,995,994)
+var4%R(3)%D = reshape([t2(199,299,399), t2(499,599,699), t2(1199,1299,1399), t2(1499,1599,1699)], [2,2])
+
+!$omp target map(to: var3%Q) map(tofrom: var4%Q)
+ call foo(var3%Q, var4%Q)
+!$omp end target
+
+!$omp target map(to: var3%R(2)) map(tofrom: var4%R(3))
+ call foo(var3%R(2), var4%R(3))
+!$omp end target
+
+if (var4%Q%A /= 45) stop 13
+if (any (var4%Q%B /= [1,2,3])) stop 14
+if (var4%Q%C%x /= 6) stop 15
+if (var4%Q%C%y /= 5) stop 15
+if (var4%Q%C%z /= 4) stop 15
+if (any (var4%Q%D(:,:)%x /= reshape([1, 4, 11, 14], [2,2]))) stop 16
+if (any (var4%Q%D(:,:)%y /= reshape([2, 5, 12, 15], [2,2]))) stop 16
+if (any (var4%Q%D(:,:)%z /= reshape([3, 6, 13, 16], [2,2]))) stop 16
+
+if (var4%R(3)%A /= 45) stop 17
+if (any (var4%R(3)%B /= [1,2,3])) stop 18
+if (var4%R(3)%C%x /= 6) stop 19
+if (var4%R(3)%C%y /= 5) stop 19
+if (var4%R(3)%C%z /= 4) stop 19
+if (any (var4%R(3)%D(:,:)%x /= reshape([1, 4, 11, 14], [2,2]))) stop 20
+if (any (var4%R(3)%D(:,:)%y /= reshape([2, 5, 12, 15], [2,2]))) stop 20
+if (any (var4%R(3)%D(:,:)%z /= reshape([3, 6, 13, 16], [2,2]))) stop 20
+
+contains
+ subroutine foo(x, y)
+ type(t) :: x, y
+ if (x%A /= 45) stop 1
+ if (any (x%B /= [1,2,3])) stop 2
+ if (x%C%x /= 6) stop 3
+ if (x%C%y /= 5) stop 3
+ if (x%C%z /= 4) stop 3
+ if (any (x%D(:,:)%x /= reshape([1, 4, 11, 14], [2,2]))) stop 4
+ if (any (x%D(:,:)%y /= reshape([2, 5, 12, 15], [2,2]))) stop 4
+ if (any (x%D(:,:)%z /= reshape([3, 6, 13, 16], [2,2]))) stop 4
+
+ if (y%A /= 145) stop 5
+ if (any (y%B /= [991,992,993])) stop 6
+ if (y%C%x /= 996) stop 7
+ if (y%C%y /= 995) stop 7
+ if (y%C%z /= 994) stop 7
+ if (any (y%D(:,:)%x /= reshape([199, 499, 1199, 1499], [2,2]))) stop 8
+ if (any (y%D(:,:)%y /= reshape([299, 599, 1299, 1599], [2,2]))) stop 8
+ if (any (y%D(:,:)%z /= reshape([399, 699, 1399, 1699], [2,2]))) stop 8
+
+ y%A = x%A
+ y%B(:) = x%B
+ y%C = x%C
+ y%D(:,:) = x%D(:,:)
+ end
+end
new file mode 100644
@@ -0,0 +1,124 @@
+type t2
+ integer x, y, z
+end type t2
+type t
+ integer, allocatable :: A
+ integer, allocatable :: B(:)
+ type(t2), allocatable :: C
+ type(t2), allocatable :: D(:,:)
+end type t
+
+type t3
+ type(t) :: Q
+ type(t) :: R(5)
+end type
+
+type(t) :: var, var2
+type(t3) :: var3, var4
+
+! --------------------------------------
+! Assign + allocate
+var%A = 45
+var%B = [1,2,3]
+var%C = t2(6,5,4)
+var%D = reshape([t2(1,2,3), t2(4,5,6), t2(11,12,13), t2(14,15,16)], [2,2])
+
+! Assign + allocate
+var2%A = 145
+var2%B = [991,992,993]
+var2%C = t2(996,995,994)
+var2%D = reshape([t2(199,299,399), t2(499,599,699), t2(1199,1299,1399), t2(1499,1599,1699)], [2,2])
+
+
+!$omp target map(to: var%A, var%B, var%C, var%D) &
+!$omp& map(tofrom: var2%A, var2%B, var2%C, var2%D)
+ call foo(var, var2)
+!$omp end target
+
+if (var2%A /= 45) stop 9
+if (any (var2%B /= [1,2,3])) stop 10
+if (var2%C%x /= 6) stop 11
+if (var2%C%y /= 5) stop 11
+if (var2%C%z /= 4) stop 11
+if (any (var2%D(:,:)%x /= reshape([1, 4, 11, 14], [2,2]))) stop 12
+if (any (var2%D(:,:)%y /= reshape([2, 5, 12, 15], [2,2]))) stop 12
+if (any (var2%D(:,:)%z /= reshape([3, 6, 13, 16], [2,2]))) stop 12
+
+! --------------------------------------
+! Assign + allocate
+var3%Q%A = 45
+var3%Q%B = [1,2,3]
+var3%Q%C = t2(6,5,4)
+var3%Q%D = reshape([t2(1,2,3), t2(4,5,6), t2(11,12,13), t2(14,15,16)], [2,2])
+
+var3%R(2)%A = 45
+var3%R(2)%B = [1,2,3]
+var3%R(2)%C = t2(6,5,4)
+var3%R(2)%D = reshape([t2(1,2,3), t2(4,5,6), t2(11,12,13), t2(14,15,16)], [2,2])
+
+! Assign + allocate
+var4%Q%A = 145
+var4%Q%B = [991,992,993]
+var4%Q%C = t2(996,995,994)
+var4%Q%D = reshape([t2(199,299,399), t2(499,599,699), t2(1199,1299,1399), t2(1499,1599,1699)], [2,2])
+
+var4%R(3)%A = 145
+var4%R(3)%B = [991,992,993]
+var4%R(3)%C = t2(996,995,994)
+var4%R(3)%D = reshape([t2(199,299,399), t2(499,599,699), t2(1199,1299,1399), t2(1499,1599,1699)], [2,2])
+
+!$omp target map(to: var3%Q%A, var3%Q%B, var3%Q%C, var3%Q%D) &
+!$omp& map(tofrom: var4%Q%A, var4%Q%B, var4%Q%C, var4%Q%D)
+ call foo(var3%Q, var4%Q)
+!$omp end target
+
+if (var4%Q%A /= 45) stop 13
+if (any (var4%Q%B /= [1,2,3])) stop 14
+if (var4%Q%C%x /= 6) stop 15
+if (var4%Q%C%y /= 5) stop 15
+if (var4%Q%C%z /= 4) stop 15
+if (any (var4%Q%D(:,:)%x /= reshape([1, 4, 11, 14], [2,2]))) stop 16
+if (any (var4%Q%D(:,:)%y /= reshape([2, 5, 12, 15], [2,2]))) stop 16
+if (any (var4%Q%D(:,:)%z /= reshape([3, 6, 13, 16], [2,2]))) stop 16
+
+!$omp target map(to: var3%R(2)%A, var3%R(2)%B, var3%R(2)%C, var3%R(2)%D) &
+!$omp& map(tofrom: var4%R(3)%A, var4%R(3)%B, var4%R(3)%C, var4%R(3)%D)
+ call foo(var3%R(2), var4%R(3))
+!$omp end target
+
+if (var4%R(3)%A /= 45) stop 17
+if (any (var4%R(3)%B /= [1,2,3])) stop 18
+if (var4%R(3)%C%x /= 6) stop 19
+if (var4%R(3)%C%y /= 5) stop 19
+if (var4%R(3)%C%z /= 4) stop 19
+if (any (var4%R(3)%D(:,:)%x /= reshape([1, 4, 11, 14], [2,2]))) stop 20
+if (any (var4%R(3)%D(:,:)%y /= reshape([2, 5, 12, 15], [2,2]))) stop 20
+if (any (var4%R(3)%D(:,:)%z /= reshape([3, 6, 13, 16], [2,2]))) stop 20
+
+contains
+ subroutine foo(x, y)
+ type(t) :: x, y
+ if (x%A /= 45) stop 1
+ if (any (x%B /= [1,2,3])) stop 2
+ if (x%C%x /= 6) stop 3
+ if (x%C%y /= 5) stop 3
+ if (x%C%z /= 4) stop 3
+ if (any (x%D(:,:)%x /= reshape([1, 4, 11, 14], [2,2]))) stop 4
+ if (any (x%D(:,:)%y /= reshape([2, 5, 12, 15], [2,2]))) stop 4
+ if (any (x%D(:,:)%z /= reshape([3, 6, 13, 16], [2,2]))) stop 4
+
+ if (y%A /= 145) stop 5
+ if (any (y%B /= [991,992,993])) stop 6
+ if (y%C%x /= 996) stop 7
+ if (y%C%y /= 995) stop 7
+ if (y%C%z /= 994) stop 7
+ if (any (y%D(:,:)%x /= reshape([199, 499, 1199, 1499], [2,2]))) stop 8
+ if (any (y%D(:,:)%y /= reshape([299, 599, 1299, 1599], [2,2]))) stop 8
+ if (any (y%D(:,:)%z /= reshape([399, 699, 1399, 1699], [2,2]))) stop 8
+
+ y%A = x%A
+ y%B(:) = x%B
+ y%C = x%C
+ y%D(:,:) = x%D(:,:)
+ end
+end
new file mode 100644
@@ -0,0 +1,53 @@
+implicit none
+type t
+ integer, allocatable :: a, b(:)
+end type t
+type(t) :: x, y, z
+integer :: i
+
+!$omp target
+ if (allocated(x%a)) stop 1
+ if (allocated(x%b)) stop 2
+!$omp end target
+
+allocate(x%a, x%b(-4:6))
+x%b(:) = [(i, i=-4,6)]
+
+!$omp target
+ if (.not. allocated(x%a)) stop 3
+ if (.not. allocated(x%b)) stop 4
+ if (lbound(x%b,1) /= -4) stop 5
+ if (ubound(x%b,1) /= 6) stop 6
+ if (any (x%b /= [(i, i=-4,6)])) stop 7
+!$omp end target
+
+
+! The following only works with arrays due to
+! PR fortran/96668
+
+!$omp target enter data map(to: y, z)
+
+!$omp target
+ if (allocated(y%b)) stop 8
+ if (allocated(z%b)) stop 9
+!$omp end target
+
+allocate(y%b(5), z%b(3))
+y%b = 42
+z%b = 99
+
+! (implicitly) 'tofrom' mapped
+! Planned for OpenMP 6.0 (but common extension)
+! OpenMP <= 5.0 unclear
+!$omp target
+ if (.not.allocated(y%b)) stop 10
+ if (any (y%b /= 42)) stop 11
+!$omp end target
+
+! always map: OpenMP 5.1 (clarified)
+!$omp target map(always, tofrom: z)
+ if (.not.allocated(z%b)) stop 12
+ if (any (z%b /= 99)) stop 13
+!$omp end target
+
+end
new file mode 100644
@@ -0,0 +1,308 @@
+! NOTE: This code uses POINTER.
+! While map(p, var%p) etc. maps the ptr/ptr comp p / var%p (incl. allocatable comps),
+! map(var) does not map var%p.
+
+use iso_c_binding
+implicit none
+type t2
+ integer, allocatable :: x, y, z
+end type t2
+type t
+ integer, pointer :: A => null()
+ integer, pointer :: B(:) => null()
+ type(t2), pointer :: C => null()
+ type(t2), pointer :: D(:,:) => null()
+end type t
+
+type t3
+ type(t) :: Q
+ type(t) :: R(5)
+end type
+
+type(t) :: var, var2
+type(t3) :: var3, var4
+integer(c_intptr_t) :: iptr
+
+! --------------------------------------
+! Assign + allocate
+allocate (var%A, source=45)
+allocate (var%B(3), source=[1,2,3])
+allocate (var%C)
+var%C%x = 6; var%C%y = 5; var%C%z = 4
+allocate (var%D(2,2))
+var%D(1,1)%x = 1
+var%D(1,1)%y = 2
+var%D(1,1)%z = 3
+var%D(2,1)%x = 4
+var%D(2,1)%y = 5
+var%D(2,1)%z = 6
+var%D(1,2)%x = 11
+var%D(1,2)%y = 12
+var%D(1,2)%z = 13
+var%D(2,2)%x = 14
+var%D(2,2)%y = 15
+var%D(2,2)%z = 16
+
+! Assign + allocate
+allocate (var2%A, source=145)
+allocate (var2%B, source=[991,992,993])
+allocate (var2%C)
+var2%C%x = 996; var2%C%y = 995; var2%C%z = 994
+allocate (var2%D(2,2))
+var2%D(1,1)%x = 199
+var2%D(1,1)%y = 299
+var2%D(1,1)%z = 399
+var2%D(2,1)%x = 499
+var2%D(2,1)%y = 599
+var2%D(2,1)%z = 699
+var2%D(1,2)%x = 1199
+var2%D(1,2)%y = 1299
+var2%D(1,2)%z = 1399
+var2%D(2,2)%x = 1499
+var2%D(2,2)%y = 1599
+var2%D(2,2)%z = 1699
+
+block
+ integer(c_intptr_t) :: loc_a, loc_b, loc_c, loc_d, loc2_a, loc2_b, loc2_c, loc2_d
+ loc_a = loc (var%a)
+ loc_b = loc (var%b)
+ loc_c = loc (var%d)
+ loc_d = loc (var%d)
+ loc2_a = loc (var2%a)
+ loc2_b = loc (var2%b)
+ loc2_c = loc (var2%c)
+ loc2_d = loc (var2%d)
+ ! var/var2 are mapped, but the pointer components aren't
+ !$omp target map(to: var) map(tofrom: var2)
+ if (loc_a /= loc (var%a)) stop 31
+ if (loc_b /= loc (var%b)) stop 32
+ if (loc_c /= loc (var%d)) stop 33
+ if (loc_d /= loc (var%d)) stop 34
+ if (loc2_a /= loc (var2%a)) stop 35
+ if (loc2_b /= loc (var2%b)) stop 36
+ if (loc2_c /= loc (var2%c)) stop 37
+ if (loc2_d /= loc (var2%d)) stop 38
+ !$omp end target
+ if (loc_a /= loc (var%a)) stop 41
+ if (loc_b /= loc (var%b)) stop 42
+ if (loc_c /= loc (var%d)) stop 43
+ if (loc_d /= loc (var%d)) stop 44
+ if (loc2_a /= loc (var2%a)) stop 45
+ if (loc2_b /= loc (var2%b)) stop 46
+ if (loc2_c /= loc (var2%c)) stop 47
+ if (loc2_d /= loc (var2%d)) stop 48
+end block
+
+block
+ ! Map only (all) components, but this maps also the alloc comps
+ !$omp target map(to: var%a, var%b, var%c, var%d) map(tofrom: var2%a, var2%b, var2%c, var2%d)
+ call foo (var,var2)
+ !$omp end target
+end block
+
+if (var2%A /= 45) stop 9
+if (any (var2%B /= [1,2,3])) stop 10
+if (var2%C%x /= 6) stop 11
+if (var2%C%y /= 5) stop 11
+if (var2%C%z /= 4) stop 11
+block
+ integer :: tmp_x(2,2), tmp_y(2,2), tmp_z(2,2), i, j
+ tmp_x = reshape([1, 4, 11, 14], [2,2])
+ tmp_y = reshape([2, 5, 12, 15], [2,2])
+ tmp_z = reshape([3, 6, 13, 16], [2,2])
+ do j = 1, 2
+ do i = 1, 2
+ if (var2%D(i,j)%x /= tmp_x(i,j)) stop 12
+ if (var2%D(i,j)%y /= tmp_y(i,j)) stop 12
+ if (var2%D(i,j)%z /= tmp_z(i,j)) stop 12
+ end do
+ end do
+end block
+
+! Extra deallocates due to PR fortran/104697
+deallocate(var%C%x, var%C%y, var%C%z)
+deallocate(var%D(1,1)%x, var%D(1,1)%y, var%D(1,1)%z)
+deallocate(var%D(2,1)%x, var%D(2,1)%y, var%D(2,1)%z)
+deallocate(var%D(1,2)%x, var%D(1,2)%y, var%D(1,2)%z)
+deallocate(var%D(2,2)%x, var%D(2,2)%y, var%D(2,2)%z)
+deallocate(var%A, var%B, var%C, var%D)
+
+deallocate(var2%C%x, var2%C%y, var2%C%z)
+deallocate(var2%D(1,1)%x, var2%D(1,1)%y, var2%D(1,1)%z)
+deallocate(var2%D(2,1)%x, var2%D(2,1)%y, var2%D(2,1)%z)
+deallocate(var2%D(1,2)%x, var2%D(1,2)%y, var2%D(1,2)%z)
+deallocate(var2%D(2,2)%x, var2%D(2,2)%y, var2%D(2,2)%z)
+deallocate(var2%A, var2%B, var2%C, var2%D)
+
+! --------------------------------------
+! Assign + allocate
+allocate (var3%Q%A, source=45)
+allocate (var3%Q%B, source=[1,2,3])
+allocate (var3%Q%C, source=t2(6,5,4))
+allocate (var3%Q%D(2,2))
+var3%Q%D(1,1) = t2(1,2,3)
+var3%Q%D(2,1) = t2(4,5,6)
+var3%Q%D(1,2) = t2(11,12,13)
+var3%Q%D(2,2) = t2(14,15,16)
+
+allocate (var3%R(2)%A, source=45)
+allocate (var3%R(2)%B, source=[1,2,3])
+allocate (var3%R(2)%C, source=t2(6,5,4))
+allocate (var3%R(2)%D(2,2))
+var3%R(2)%D(1,1) = t2(1,2,3)
+var3%R(2)%D(2,1) = t2(4,5,6)
+var3%R(2)%D(1,2) = t2(11,12,13)
+var3%R(2)%D(2,2) = t2(14,15,16)
+
+! Assign + allocate
+allocate (var4%Q%A, source=145)
+allocate (var4%Q%B, source=[991,992,993])
+allocate (var4%Q%C, source=t2(996,995,994))
+allocate (var4%Q%D(2,2))
+var4%Q%D(1,1) = t2(199,299,399)
+var4%Q%D(2,1) = t2(499,599,699)
+var4%Q%D(1,2) = t2(1199,1299,1399)
+var4%Q%D(2,2) = t2(1499,1599,1699)
+
+allocate (var4%R(3)%A, source=145)
+allocate (var4%R(3)%B, source=[991,992,993])
+allocate (var4%R(3)%C, source=t2(996,995,994))
+allocate (var4%R(3)%D(2,2))
+var4%R(3)%D(1,1) = t2(199,299,399)
+var4%R(3)%D(2,1) = t2(499,599,699)
+var4%R(3)%D(1,2) = t2(1199,1299,1399)
+var4%R(3)%D(2,2) = t2(1499,1599,1699)
+
+!$omp target map(to: var3%Q%A, var3%Q%B, var3%Q%C, var3%Q%D) &
+!$omp& map(tofrom: var4%Q%A, var4%Q%B, var4%Q%C, var4%Q%D)
+ call foo(var3%Q, var4%Q)
+!$omp end target
+
+iptr = loc(var3%R(2)%A)
+
+!$omp target map(to: var3%R(2)%A, var3%R(2)%B, var3%R(2)%C, var3%R(2)%D) &
+!$omp& map(tofrom: var4%R(3)%A, var4%R(3)%B, var4%R(3)%C, var4%R(3)%D)
+ call foo(var3%R(2), var4%R(3))
+!$omp end target
+
+if (var4%Q%A /= 45) stop 13
+if (any (var4%Q%B /= [1,2,3])) stop 14
+if (var4%Q%C%x /= 6) stop 15
+if (var4%Q%C%y /= 5) stop 15
+if (var4%Q%C%z /= 4) stop 15
+block
+ integer :: tmp_x(2,2), tmp_y(2,2), tmp_z(2,2), i, j
+ tmp_x = reshape([1, 4, 11, 14], [2,2])
+ tmp_y = reshape([2, 5, 12, 15], [2,2])
+ tmp_z = reshape([3, 6, 13, 16], [2,2])
+ do j = 1, 2
+ do i = 1, 2
+ if (var4%Q%D(i,j)%x /= tmp_x(i,j)) stop 16
+ if (var4%Q%D(i,j)%y /= tmp_y(i,j)) stop 16
+ if (var4%Q%D(i,j)%z /= tmp_z(i,j)) stop 16
+ end do
+ end do
+end block
+
+! Cf. PR fortran/104696
+! { dg-output "valid mapping, OK" { xfail { offload_device_nonshared_as } } }
+if (iptr /= loc(var3%R(2)%A)) then
+ print *, "invalid mapping, cf. PR fortran/104696"
+else
+
+if (var4%R(3)%A /= 45) stop 17
+if (any (var4%R(3)%B /= [1,2,3])) stop 18
+if (var4%R(3)%C%x /= 6) stop 19
+if (var4%R(3)%C%y /= 5) stop 19
+if (var4%R(3)%C%z /= 4) stop 19
+block
+ integer :: tmp_x(2,2), tmp_y(2,2), tmp_z(2,2), i, j
+ tmp_x = reshape([1, 4, 11, 14], [2,2])
+ tmp_y = reshape([2, 5, 12, 15], [2,2])
+ tmp_z = reshape([3, 6, 13, 16], [2,2])
+ do j = 1, 2
+ do i = 1, 2
+ if (var4%R(3)%D(i,j)%x /= tmp_x(i,j)) stop 20
+ if (var4%R(3)%D(i,j)%y /= tmp_y(i,j)) stop 20
+ if (var4%R(3)%D(i,j)%z /= tmp_z(i,j)) stop 20
+ end do
+ end do
+end block
+
+! Extra deallocates due to PR fortran/104697
+deallocate(var3%Q%C%x, var3%Q%D(1,1)%x, var3%Q%D(2,1)%x, var3%Q%D(1,2)%x, var3%Q%D(2,2)%x)
+deallocate(var3%Q%C%y, var3%Q%D(1,1)%y, var3%Q%D(2,1)%y, var3%Q%D(1,2)%y, var3%Q%D(2,2)%y)
+deallocate(var3%Q%C%z, var3%Q%D(1,1)%z, var3%Q%D(2,1)%z, var3%Q%D(1,2)%z, var3%Q%D(2,2)%z)
+deallocate(var3%Q%A, var3%Q%B, var3%Q%C, var3%Q%D)
+
+deallocate(var4%Q%C%x, var4%Q%D(1,1)%x, var4%Q%D(2,1)%x, var4%Q%D(1,2)%x, var4%Q%D(2,2)%x)
+deallocate(var4%Q%C%y, var4%Q%D(1,1)%y, var4%Q%D(2,1)%y, var4%Q%D(1,2)%y, var4%Q%D(2,2)%y)
+deallocate(var4%Q%C%z, var4%Q%D(1,1)%z, var4%Q%D(2,1)%z, var4%Q%D(1,2)%z, var4%Q%D(2,2)%z)
+deallocate(var4%Q%A, var4%Q%B, var4%Q%C, var4%Q%D)
+
+deallocate(var3%R(2)%C%x, var3%R(2)%D(1,1)%x, var3%R(2)%D(2,1)%x, var3%R(2)%D(1,2)%x, var3%R(2)%D(2,2)%x)
+deallocate(var3%R(2)%C%y, var3%R(2)%D(1,1)%y, var3%R(2)%D(2,1)%y, var3%R(2)%D(1,2)%y, var3%R(2)%D(2,2)%y)
+deallocate(var3%R(2)%C%z, var3%R(2)%D(1,1)%z, var3%R(2)%D(2,1)%z, var3%R(2)%D(1,2)%z, var3%R(2)%D(2,2)%z)
+deallocate(var3%R(2)%A, var3%R(2)%B, var3%R(2)%C, var3%R(2)%D)
+
+deallocate(var4%R(3)%C%x, var4%R(3)%D(1,1)%x, var4%R(3)%D(2,1)%x, var4%R(3)%D(1,2)%x, var4%R(3)%D(2,2)%x)
+deallocate(var4%R(3)%C%y, var4%R(3)%D(1,1)%y, var4%R(3)%D(2,1)%y, var4%R(3)%D(1,2)%y, var4%R(3)%D(2,2)%y)
+deallocate(var4%R(3)%C%z, var4%R(3)%D(1,1)%z, var4%R(3)%D(2,1)%z, var4%R(3)%D(1,2)%z, var4%R(3)%D(2,2)%z)
+deallocate(var4%R(3)%A, var4%R(3)%B, var4%R(3)%C, var4%R(3)%D)
+
+ print *, "valid mapping, OK"
+endif
+
+contains
+ subroutine foo(x, y)
+ type(t) :: x, y
+ intent(in) :: x
+ intent(inout) :: y
+ integer :: tmp_x(2,2), tmp_y(2,2), tmp_z(2,2), i, j
+ if (x%A /= 45) stop 1
+ if (any (x%B /= [1,2,3])) stop 2
+ if (x%C%x /= 6) stop 3
+ if (x%C%y /= 5) stop 3
+ if (x%C%z /= 4) stop 3
+
+ tmp_x = reshape([1, 4, 11, 14], [2,2])
+ tmp_y = reshape([2, 5, 12, 15], [2,2])
+ tmp_z = reshape([3, 6, 13, 16], [2,2])
+ do j = 1, 2
+ do i = 1, 2
+ if (x%D(i,j)%x /= tmp_x(i,j)) stop 4
+ if (x%D(i,j)%y /= tmp_y(i,j)) stop 4
+ if (x%D(i,j)%z /= tmp_z(i,j)) stop 4
+ end do
+ end do
+
+ if (y%A /= 145) stop 5
+ if (any (y%B /= [991,992,993])) stop 6
+ if (y%C%x /= 996) stop 7
+ if (y%C%y /= 995) stop 7
+ if (y%C%z /= 994) stop 7
+ tmp_x = reshape([199, 499, 1199, 1499], [2,2])
+ tmp_y = reshape([299, 599, 1299, 1599], [2,2])
+ tmp_z = reshape([399, 699, 1399, 1699], [2,2])
+ do j = 1, 2
+ do i = 1, 2
+ if (y%D(i,j)%x /= tmp_x(i,j)) stop 8
+ if (y%D(i,j)%y /= tmp_y(i,j)) stop 8
+ if (y%D(i,j)%z /= tmp_z(i,j)) stop 8
+ end do
+ end do
+
+ y%A = x%A
+ y%B(:) = x%B
+ y%C%x = x%C%x
+ y%C%y = x%C%y
+ y%C%z = x%C%z
+ do j = 1, 2
+ do i = 1, 2
+ y%D(i,j)%x = x%D(i,j)%x
+ y%D(i,j)%y = x%D(i,j)%y
+ y%D(i,j)%z = x%D(i,j)%z
+ end do
+ end do
+ end
+end
new file mode 100644
@@ -0,0 +1,672 @@
+module m
+ implicit none (type, external)
+ type t
+ integer, allocatable :: arr(:,:)
+ integer :: var
+ integer, allocatable :: slr
+ end type t
+
+contains
+
+ subroutine check_it (is_present, dummy_alloced, inner_alloc, &
+ scalar, array, a_scalar, a_array, &
+ l_scalar, l_array, la_scalar, la_array, &
+ opt_scalar, opt_array, a_opt_scalar, a_opt_array)
+ type(t), intent(inout) :: &
+ scalar, array(:,:), opt_scalar, opt_array(:,:), a_scalar, a_array(:,:), &
+ a_opt_scalar, a_opt_array(:,:), &
+ l_scalar, l_array(:,:), la_scalar, la_array(:,:)
+ optional :: opt_scalar, opt_array, a_opt_scalar, a_opt_array
+ allocatable :: a_scalar, a_array, a_opt_scalar, a_opt_array, la_scalar, la_array
+ logical, value :: is_present, dummy_alloced, inner_alloc
+ integer :: i, j, k, l
+
+ ! CHECK VALUE
+ if (scalar%var /= 42) stop 1
+ if (l_scalar%var /= 42) stop 1
+ if (is_present) then
+ if (opt_scalar%var /= 42) stop 2
+ end if
+ if (any (shape(array) /= [3,2])) stop 1
+ if (any (shape(l_array) /= [3,2])) stop 1
+ if (is_present) then
+ if (any (shape(opt_array) /= [3,2])) stop 1
+ end if
+ do j = 1, 2
+ do i = 1, 3
+ if (array(i,j)%var /= i*97 + 100*41*j) stop 3
+ if (l_array(i,j)%var /= i*97 + 100*41*j) stop 3
+ if (is_present) then
+ if (opt_array(i,j)%var /= i*97 + 100*41*j) stop 4
+ end if
+ end do
+ end do
+
+ if (dummy_alloced) then
+ if (a_scalar%var /= 42) stop 1
+ if (la_scalar%var /= 42) stop 1
+ if (is_present) then
+ if (a_opt_scalar%var /= 42) stop 1
+ end if
+ if (any (shape(a_array) /= [3,2])) stop 1
+ if (any (shape(la_array) /= [3,2])) stop 1
+ if (is_present) then
+ if (any (shape(a_opt_array) /= [3,2])) stop 1
+ end if
+ do j = 1, 2
+ do i = 1, 3
+ if (a_array(i,j)%var /= i*97 + 100*41*j) stop 1
+ if (la_array(i,j)%var /= i*97 + 100*41*j) stop 1
+ if (is_present) then
+ if (a_opt_array(i,j)%var /= i*97 + 100*41*j) stop 1
+ end if
+ end do
+ end do
+ else
+ if (allocated (a_scalar)) stop 1
+ if (allocated (la_scalar)) stop 1
+ if (allocated (a_array)) stop 1
+ if (allocated (la_array)) stop 1
+ if (is_present) then
+ if (allocated (a_opt_scalar)) stop 1
+ if (allocated (a_opt_array)) stop 1
+ end if
+ end if
+
+ if (inner_alloc) then
+ if (scalar%slr /= 467) stop 5
+ if (l_scalar%slr /= 467) stop 5
+ if (a_scalar%slr /= 467) stop 6
+ if (la_scalar%slr /= 467) stop 6
+ if (is_present) then
+ if (opt_scalar%slr /= 467) stop 7
+ if (a_opt_scalar%slr /= 467) stop 8
+ end if
+ do j = 1, 2
+ do i = 1, 3
+ if (array(i,j)%slr /= (i*97 + 100*41*j) + 467) stop 9
+ if (l_array(i,j)%slr /= (i*97 + 100*41*j) + 467) stop 9
+ if (a_array(i,j)%slr /= (i*97 + 100*41*j) + 467) stop 10
+ if (la_array(i,j)%slr /= (i*97 + 100*41*j) + 467) stop 10
+ if (is_present) then
+ if (opt_array(i,j)%slr /= (i*97 + 100*41*j) + 467) stop 11
+ if (a_opt_array(i,j)%slr /= (i*97 + 100*41*j) + 467) stop 12
+ end if
+ end do
+ end do
+
+ do l = 1, 5
+ do k = 1, 4
+ if (any (shape(scalar%arr) /= [4,5])) stop 1
+ if (any (shape(l_scalar%arr) /= [4,5])) stop 1
+ if (any (shape(a_scalar%arr) /= [4,5])) stop 1
+ if (any (shape(la_scalar%arr) /= [4,5])) stop 1
+ if (scalar%arr(k,l) /= (i*27 + 1000*11*j) + 467) stop 13
+ if (l_scalar%arr(k,l) /= (i*27 + 1000*11*j) + 467) stop 13
+ if (a_scalar%arr(k,l) /= (i*27 + 1000*11*j) + 467) stop 14
+ if (la_scalar%arr(k,l) /= (i*27 + 1000*11*j) + 467) stop 14
+ if (is_present) then
+ if (any (shape(opt_scalar%arr) /= [4,5])) stop 1
+ if (any (shape(a_opt_scalar%arr) /= [4,5])) stop 1
+ if (opt_scalar%arr(k,l) /= (i*27 + 1000*11*j) + 467) stop 15
+ if (a_opt_scalar%arr(k,l) /= (i*27 + 1000*11*j) + 467) stop 16
+ end if
+ end do
+ end do
+ do j = 1, 2
+ do i = 1, 3
+ if (any (shape(array(i,j)%arr) /= [i,j])) stop 1
+ if (any (shape(l_array(i,j)%arr) /= [i,j])) stop 1
+ if (any (shape(a_array(i,j)%arr) /= [i,j])) stop 1
+ if (any (shape(la_array(i,j)%arr) /= [i,j])) stop 1
+ if (is_present) then
+ if (any (shape(opt_array(i,j)%arr) /= [i,j])) stop 1
+ if (any (shape(a_opt_array(i,j)%arr) /= [i,j])) stop 1
+ endif
+ do l = 1, j
+ do k = 1, i
+ if (array(i,j)%arr(k,l) /= i*27 + 1000*11*j + 467 + 3*k +53*l) stop 17
+ if (l_array(i,j)%arr(k,l) /= i*27 + 1000*11*j + 467 + 3*k +53*l) stop 17
+ if (a_array(i,j)%arr(k,l) /= i*27 + 1000*11*j + 467 + 3*k +53*l) stop 18
+ if (la_array(i,j)%arr(k,l) /= i*27 + 1000*11*j + 467 + 3*k +53*l) stop 18
+ if (is_present) then
+ if (opt_array(i,j)%arr(k,l) /= i*27 + 1000*11*j + 467 + 3*k +53*l) stop 19
+ if (a_opt_array(i,j)%arr(k,l) /= i*27 + 1000*11*j + 467 + 3*k +53*l) stop 20
+ end if
+ end do
+ end do
+ end do
+ end do
+ else if (dummy_alloced) then
+ if (allocated (scalar%slr)) stop 1
+ if (allocated (l_scalar%slr)) stop 1
+ if (allocated (a_scalar%slr)) stop 1
+ if (allocated (la_scalar%slr)) stop 1
+ if (is_present) then
+ if (allocated (opt_scalar%slr)) stop 1
+ if (allocated (a_opt_scalar%slr)) stop 1
+ endif
+ if (allocated (scalar%arr)) stop 1
+ if (allocated (l_scalar%arr)) stop 1
+ if (allocated (a_scalar%arr)) stop 1
+ if (allocated (la_scalar%arr)) stop 1
+ if (is_present) then
+ if (allocated (opt_scalar%arr)) stop 1
+ if (allocated (a_opt_scalar%arr)) stop 1
+ endif
+ end if
+
+ ! SET VALUE
+ scalar%var = 42 + 13
+ l_scalar%var = 42 + 13
+ if (is_present) then
+ opt_scalar%var = 42 + 13
+ endif
+ do j = 1, 2
+ do i = 1, 3
+ array(i,j)%var = i*97 + 100*41*j + 13
+ l_array(i,j)%var = i*97 + 100*41*j + 13
+ if (is_present) then
+ opt_array(i,j)%var = i*97 + 100*41*j + 13
+ end if
+ end do
+ end do
+
+ if (dummy_alloced) then
+ a_scalar%var = 42 + 13
+ la_scalar%var = 42 + 13
+ if (is_present) then
+ a_opt_scalar%var = 42 + 13
+ endif
+ do j = 1, 2
+ do i = 1, 3
+ a_array(i,j)%var = i*97 + 100*41*j + 13
+ la_array(i,j)%var = i*97 + 100*41*j + 13
+ if (is_present) then
+ a_opt_array(i,j)%var = i*97 + 100*41*j + 13
+ endif
+ end do
+ end do
+ end if
+
+ if (inner_alloc) then
+ scalar%slr = 467 + 13
+ l_scalar%slr = 467 + 13
+ a_scalar%slr = 467 + 13
+ la_scalar%slr = 467 + 13
+ if (is_present) then
+ opt_scalar%slr = 467 + 13
+ a_opt_scalar%slr = 467 + 13
+ end if
+ do j = 1, 2
+ do i = 1, 3
+ array(i,j)%slr = (i*97 + 100*41*j) + 467 + 13
+ l_array(i,j)%slr = (i*97 + 100*41*j) + 467 + 13
+ a_array(i,j)%slr = (i*97 + 100*41*j) + 467 + 13
+ la_array(i,j)%slr = (i*97 + 100*41*j) + 467 + 13
+ if (is_present) then
+ opt_array(i,j)%slr = (i*97 + 100*41*j) + 467 + 13
+ a_opt_array(i,j)%slr = (i*97 + 100*41*j) + 467 + 13
+ end if
+ end do
+ end do
+
+ do l = 1, 5
+ do k = 1, 4
+ scalar%arr(k,l) = (i*27 + 1000*11*j) + 467 + 13
+ l_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467 + 13
+ a_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467 + 13
+ la_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467 + 13
+ if (is_present) then
+ opt_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467 + 13
+ a_opt_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467 + 13
+ end if
+ end do
+ end do
+ do j = 1, 2
+ do i = 1, 3
+ do l = 1, j
+ do k = 1, i
+ array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l + 13
+ l_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l + 13
+ a_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l + 13
+ la_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l + 13
+ if (is_present) then
+ opt_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l + 13
+ a_opt_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l + 13
+ end if
+ end do
+ end do
+ end do
+ end do
+ end if
+
+ end subroutine
+ subroutine check_reset (is_present, dummy_alloced, inner_alloc, &
+ scalar, array, a_scalar, a_array, &
+ l_scalar, l_array, la_scalar, la_array, &
+ opt_scalar, opt_array, a_opt_scalar, a_opt_array)
+ type(t), intent(inout) :: &
+ scalar, array(:,:), opt_scalar, opt_array(:,:), a_scalar, a_array(:,:), &
+ a_opt_scalar, a_opt_array(:,:), &
+ l_scalar, l_array(:,:), la_scalar, la_array(:,:)
+ optional :: opt_scalar, opt_array, a_opt_scalar, a_opt_array
+ allocatable :: a_scalar, a_array, a_opt_scalar, a_opt_array, la_scalar, la_array
+ logical, value :: is_present, dummy_alloced, inner_alloc
+ integer :: i, j, k, l
+
+ ! CHECK VALUE
+ if (scalar%var /= 42 + 13) stop 1
+ if (l_scalar%var /= 42 + 13) stop 1
+ if (is_present) then
+ if (opt_scalar%var /= 42 + 13) stop 2
+ end if
+ if (any (shape(array) /= [3,2])) stop 1
+ if (any (shape(l_array) /= [3,2])) stop 1
+ if (is_present) then
+ if (any (shape(opt_array) /= [3,2])) stop 1
+ end if
+ do j = 1, 2
+ do i = 1, 3
+ if (array(i,j)%var /= i*97 + 100*41*j + 13) stop 3
+ if (l_array(i,j)%var /= i*97 + 100*41*j + 13) stop 3
+ if (is_present) then
+ if (opt_array(i,j)%var /= i*97 + 100*41*j + 13) stop 4
+ end if
+ end do
+ end do
+
+ if (dummy_alloced) then
+ if (a_scalar%var /= 42 + 13) stop 1
+ if (la_scalar%var /= 42 + 13) stop 1
+ if (is_present) then
+ if (a_opt_scalar%var /= 42 + 13) stop 1
+ end if
+ if (any (shape(a_array) /= [3,2])) stop 1
+ if (any (shape(la_array) /= [3,2])) stop 1
+ if (is_present) then
+ if (any (shape(a_opt_array) /= [3,2])) stop 1
+ end if
+ do j = 1, 2
+ do i = 1, 3
+ if (a_array(i,j)%var /= i*97 + 100*41*j + 13) stop 1
+ if (la_array(i,j)%var /= i*97 + 100*41*j + 13) stop 1
+ if (is_present) then
+ if (a_opt_array(i,j)%var /= i*97 + 100*41*j + 13) stop 1
+ end if
+ end do
+ end do
+ else
+ if (allocated (a_scalar)) stop 1
+ if (allocated (la_scalar)) stop 1
+ if (allocated (a_array)) stop 1
+ if (allocated (la_array)) stop 1
+ if (is_present) then
+ if (allocated (a_opt_scalar)) stop 1
+ if (allocated (a_opt_array)) stop 1
+ end if
+ end if
+
+ if (inner_alloc) then
+ if (scalar%slr /= 467 + 13) stop 5
+ if (l_scalar%slr /= 467 + 13) stop 5
+ if (a_scalar%slr /= 467 + 13) stop 6
+ if (la_scalar%slr /= 467 + 13) stop 6
+ if (is_present) then
+ if (opt_scalar%slr /= 467 + 13) stop 7
+ if (a_opt_scalar%slr /= 467 + 13) stop 8
+ end if
+ do j = 1, 2
+ do i = 1, 3
+ if (array(i,j)%slr /= (i*97 + 100*41*j) + 467 + 13) stop 9
+ if (l_array(i,j)%slr /= (i*97 + 100*41*j) + 467 + 13) stop 9
+ if (a_array(i,j)%slr /= (i*97 + 100*41*j) + 467 + 13) stop 10
+ if (la_array(i,j)%slr /= (i*97 + 100*41*j) + 467 + 13) stop 10
+ if (is_present) then
+ if (opt_array(i,j)%slr /= (i*97 + 100*41*j) + 467 + 13) stop 11
+ if (a_opt_array(i,j)%slr /= (i*97 + 100*41*j) + 467 + 13) stop 12
+ end if
+ end do
+ end do
+
+ do l = 1, 5
+ do k = 1, 4
+ if (any (shape(scalar%arr) /= [4,5])) stop 1
+ if (any (shape(l_scalar%arr) /= [4,5])) stop 1
+ if (any (shape(a_scalar%arr) /= [4,5])) stop 1
+ if (any (shape(la_scalar%arr) /= [4,5])) stop 1
+ if (scalar%arr(k,l) /= (i*27 + 1000*11*j) + 467 + 13) stop 13
+ if (l_scalar%arr(k,l) /= (i*27 + 1000*11*j) + 467 + 13) stop 13
+ if (a_scalar%arr(k,l) /= (i*27 + 1000*11*j) + 467 + 13) stop 14
+ if (la_scalar%arr(k,l) /= (i*27 + 1000*11*j) + 467 + 13) stop 14
+ if (is_present) then
+ if (any (shape(opt_scalar%arr) /= [4,5])) stop 1
+ if (any (shape(a_opt_scalar%arr) /= [4,5])) stop 1
+ if (opt_scalar%arr(k,l) /= (i*27 + 1000*11*j) + 467 + 13) stop 15
+ if (a_opt_scalar%arr(k,l) /= (i*27 + 1000*11*j) + 467 + 13) stop 16
+ end if
+ end do
+ end do
+ do j = 1, 2
+ do i = 1, 3
+ if (any (shape(array(i,j)%arr) /= [i,j])) stop 1
+ if (any (shape(l_array(i,j)%arr) /= [i,j])) stop 1
+ if (any (shape(a_array(i,j)%arr) /= [i,j])) stop 1
+ if (any (shape(la_array(i,j)%arr) /= [i,j])) stop 1
+ if (is_present) then
+ if (any (shape(opt_array(i,j)%arr) /= [i,j])) stop 1
+ if (any (shape(a_opt_array(i,j)%arr) /= [i,j])) stop 1
+ endif
+ do l = 1, j
+ do k = 1, i
+ if (array(i,j)%arr(k,l) /= i*27 + 1000*11*j + 467 + 3*k +53*l + 13) stop 17
+ if (l_array(i,j)%arr(k,l) /= i*27 + 1000*11*j + 467 + 3*k +53*l + 13) stop 17
+ if (a_array(i,j)%arr(k,l) /= i*27 + 1000*11*j + 467 + 3*k +53*l + 13) stop 18
+ if (la_array(i,j)%arr(k,l) /= i*27 + 1000*11*j + 467 + 3*k +53*l + 13) stop 18
+ if (is_present) then
+ if (opt_array(i,j)%arr(k,l) /= i*27 + 1000*11*j + 467 + 3*k +53*l + 13) stop 19
+ if (a_opt_array(i,j)%arr(k,l) /= i*27 + 1000*11*j + 467 + 3*k +53*l + 13) stop 20
+ end if
+ end do
+ end do
+ end do
+ end do
+ else if (dummy_alloced) then
+ if (allocated (scalar%slr)) stop 1
+ if (allocated (l_scalar%slr)) stop 1
+ if (allocated (a_scalar%slr)) stop 1
+ if (allocated (la_scalar%slr)) stop 1
+ if (is_present) then
+ if (allocated (opt_scalar%slr)) stop 1
+ if (allocated (a_opt_scalar%slr)) stop 1
+ endif
+ if (allocated (scalar%arr)) stop 1
+ if (allocated (l_scalar%arr)) stop 1
+ if (allocated (a_scalar%arr)) stop 1
+ if (allocated (la_scalar%arr)) stop 1
+ if (is_present) then
+ if (allocated (opt_scalar%arr)) stop 1
+ if (allocated (a_opt_scalar%arr)) stop 1
+ endif
+ end if
+
+ ! (RE)SET VALUE
+ scalar%var = 42
+ l_scalar%var = 42
+ if (is_present) then
+ opt_scalar%var = 42
+ endif
+ do j = 1, 2
+ do i = 1, 3
+ array(i,j)%var = i*97 + 100*41*j
+ l_array(i,j)%var = i*97 + 100*41*j
+ if (is_present) then
+ opt_array(i,j)%var = i*97 + 100*41*j
+ end if
+ end do
+ end do
+
+ if (dummy_alloced) then
+ a_scalar%var = 42
+ la_scalar%var = 42
+ if (is_present) then
+ a_opt_scalar%var = 42
+ endif
+ do j = 1, 2
+ do i = 1, 3
+ a_array(i,j)%var = i*97 + 100*41*j
+ la_array(i,j)%var = i*97 + 100*41*j
+ if (is_present) then
+ a_opt_array(i,j)%var = i*97 + 100*41*j
+ endif
+ end do
+ end do
+ end if
+
+ if (inner_alloc) then
+ scalar%slr = 467
+ l_scalar%slr = 467
+ a_scalar%slr = 467
+ la_scalar%slr = 467
+ if (is_present) then
+ opt_scalar%slr = 467
+ a_opt_scalar%slr = 467
+ end if
+ do j = 1, 2
+ do i = 1, 3
+ array(i,j)%slr = (i*97 + 100*41*j) + 467
+ l_array(i,j)%slr = (i*97 + 100*41*j) + 467
+ a_array(i,j)%slr = (i*97 + 100*41*j) + 467
+ la_array(i,j)%slr = (i*97 + 100*41*j) + 467
+ if (is_present) then
+ opt_array(i,j)%slr = (i*97 + 100*41*j) + 467
+ a_opt_array(i,j)%slr = (i*97 + 100*41*j) + 467
+ end if
+ end do
+ end do
+
+ do l = 1, 5
+ do k = 1, 4
+ scalar%arr(k,l) = (i*27 + 1000*11*j) + 467
+ l_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467
+ a_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467
+ la_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467
+ if (is_present) then
+ opt_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467
+ a_opt_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467
+ end if
+ end do
+ end do
+ do j = 1, 2
+ do i = 1, 3
+ do l = 1, j
+ do k = 1, i
+ array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l
+ l_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l
+ a_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l
+ la_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l
+ if (is_present) then
+ opt_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l
+ a_opt_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l
+ end if
+ end do
+ end do
+ end do
+ end do
+ end if
+ end subroutine
+
+ subroutine test(scalar, array, a_scalar, a_array, opt_scalar, opt_array, &
+ a_opt_scalar, a_opt_array)
+ type(t) :: scalar, array(:,:), opt_scalar, opt_array(:,:), a_scalar, a_array(:,:)
+ type(t) :: a_opt_scalar, a_opt_array(:,:)
+ type(t) :: l_scalar, l_array(3,2), la_scalar, la_array(:,:)
+ allocatable :: a_scalar, a_array, a_opt_scalar, a_opt_array, la_scalar, la_array
+ optional :: opt_scalar, opt_array, a_opt_scalar, a_opt_array
+
+ integer :: i, j, k, l
+ logical :: is_present, dummy_alloced, local_alloced, inner_alloc
+ is_present = present(opt_scalar)
+ dummy_alloced = allocated(a_scalar)
+ inner_alloc = allocated(scalar%slr)
+
+ l_scalar%var = 42
+ do j = 1, 2
+ do i = 1, 3
+ l_array(i,j)%var = i*97 + 100*41*j
+ end do
+ end do
+
+ if (dummy_alloced) then
+ allocate(la_scalar, la_array(3,2))
+ a_scalar%var = 42
+ la_scalar%var = 42
+ do j = 1, 2
+ do i = 1, 3
+ l_array(i,j)%var = i*97 + 100*41*j
+ la_array(i,j)%var = i*97 + 100*41*j
+ end do
+ end do
+ end if
+
+ if (inner_alloc) then
+ l_scalar%slr = 467
+ la_scalar%slr = 467
+ do j = 1, 2
+ do i = 1, 3
+ l_array(i,j)%slr = (i*97 + 100*41*j) + 467
+ la_array(i,j)%slr = (i*97 + 100*41*j) + 467
+ end do
+ end do
+
+ allocate(l_scalar%arr(4,5), la_scalar%arr(4,5))
+ do l = 1, 5
+ do k = 1, 4
+ l_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467
+ la_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467
+ end do
+ end do
+ do j = 1, 2
+ do i = 1, 3
+ allocate(l_array(i,j)%arr(i,j), la_array(i,j)%arr(i,j))
+ do l = 1, j
+ do k = 1, i
+ l_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l
+ la_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l
+ end do
+ end do
+ end do
+ end do
+ end if
+
+ ! implicit mapping
+ !$omp target
+ if (is_present) then
+ call check_it (is_present, dummy_alloced, inner_alloc, &
+ scalar, array, a_scalar, a_array, &
+ l_scalar, l_array, la_scalar, la_array, &
+ opt_scalar, opt_array, a_opt_scalar, a_opt_array)
+ else
+ call check_it (is_present, dummy_alloced, inner_alloc, &
+ scalar, array, a_scalar, a_array, &
+ l_scalar, l_array, la_scalar, la_array)
+ end if
+ !$omp end target
+
+ if (is_present) then
+ call check_reset (is_present, dummy_alloced, inner_alloc, &
+ scalar, array, a_scalar, a_array, &
+ l_scalar, l_array, la_scalar, la_array, &
+ opt_scalar, opt_array, a_opt_scalar, a_opt_array)
+ else
+ call check_reset (is_present, dummy_alloced, inner_alloc, &
+ scalar, array, a_scalar, a_array, &
+ l_scalar, l_array, la_scalar, la_array)
+ endif
+
+ ! explicit mapping
+ !$omp target map(scalar, array, opt_scalar, opt_array, a_scalar, a_array) &
+ !$omp& map(a_opt_scalar, a_opt_array) &
+ !$omp& map(l_scalar, l_array, la_scalar, la_array)
+ if (is_present) then
+ call check_it (is_present, dummy_alloced, inner_alloc, &
+ scalar, array, a_scalar, a_array, &
+ l_scalar, l_array, la_scalar, la_array, &
+ opt_scalar, opt_array, a_opt_scalar, a_opt_array)
+ else
+ call check_it (is_present, dummy_alloced, inner_alloc, &
+ scalar, array, a_scalar, a_array, &
+ l_scalar, l_array, la_scalar, la_array)
+ endif
+ !$omp end target
+
+ if (is_present) then
+ call check_reset (is_present, dummy_alloced, inner_alloc, &
+ scalar, array, a_scalar, a_array, &
+ l_scalar, l_array, la_scalar, la_array, &
+ opt_scalar, opt_array, a_opt_scalar, a_opt_array)
+ else
+ call check_reset (is_present, dummy_alloced, inner_alloc, &
+ scalar, array, a_scalar, a_array, &
+ l_scalar, l_array, la_scalar, la_array)
+ endif
+ end subroutine
+end module
+
+program main
+ use m
+ implicit none (type, external)
+ type(t) :: scalar, array(3,2), opt_scalar, opt_array(3,2), a_scalar, a_array(:,:)
+ type(t) :: a_opt_scalar, a_opt_array(:,:)
+ allocatable :: a_scalar, a_array, a_opt_scalar, a_opt_array
+ integer :: i, j, k, l, n
+
+ scalar%var = 42
+ opt_scalar%var = 42
+ do j = 1, 2
+ do i = 1, 3
+ array(i,j)%var = i*97 + 100*41*j
+ opt_array(i,j)%var = i*97 + 100*41*j
+ end do
+ end do
+
+ ! unallocated
+ call test (scalar, array, a_scalar, a_array)
+ call test (scalar, array, a_scalar, a_array, opt_scalar, opt_array, a_opt_scalar, a_opt_array)
+
+ ! allocated
+ allocate(a_scalar, a_opt_scalar, a_array(3,2), a_opt_array(3,2))
+ a_scalar%var = 42
+ a_opt_scalar%var = 42
+ do j = 1, 2
+ do i = 1, 3
+ a_array(i,j)%var = i*97 + 100*41*j
+ a_opt_array(i,j)%var = i*97 + 100*41*j
+ end do
+ end do
+
+ call test (scalar, array, a_scalar, a_array)
+ call test (scalar, array, a_scalar, a_array, opt_scalar, opt_array, a_opt_scalar, a_opt_array)
+
+ ! comps allocated
+ scalar%slr = 467
+ a_scalar%slr = 467
+ opt_scalar%slr = 467
+ a_opt_scalar%slr = 467
+ do j = 1, 2
+ do i = 1, 3
+ array(i,j)%slr = (i*97 + 100*41*j) + 467
+ a_array(i,j)%slr = (i*97 + 100*41*j) + 467
+ opt_array(i,j)%slr = (i*97 + 100*41*j) + 467
+ a_opt_array(i,j)%slr = (i*97 + 100*41*j) + 467
+ end do
+ end do
+
+ allocate(scalar%arr(4,5), a_scalar%arr(4,5), opt_scalar%arr(4,5), a_opt_scalar%arr(4,5))
+ do l = 1, 5
+ do k = 1, 4
+ scalar%arr(k,l) = (i*27 + 1000*11*j) + 467
+ a_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467
+ opt_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467
+ a_opt_scalar%arr(k,l) = (i*27 + 1000*11*j) + 467
+ end do
+ end do
+ do j = 1, 2
+ do i = 1, 3
+ allocate(array(i,j)%arr(i,j), a_array(i,j)%arr(i,j), opt_array(i,j)%arr(i,j), a_opt_array(i,j)%arr(i,j))
+ do l = 1, j
+ do k = 1, i
+ array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l
+ a_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l
+ opt_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l
+ a_opt_array(i,j)%arr(k,l) = i*27 + 1000*11*j + 467 + 3*k +53*l
+ end do
+ end do
+ end do
+ end do
+
+ call test (scalar, array, a_scalar, a_array)
+ call test (scalar, array, a_scalar, a_array, opt_scalar, opt_array, a_opt_scalar, a_opt_array)
+
+ deallocate(a_scalar, a_opt_scalar, a_array, a_opt_array)
+end
@@ -57,6 +57,7 @@ subroutine foo (p2, parr, host_p, host_parr, cond)
! { dg-note {variable 'D\.[0-9]+' declared in block is candidate for adjusting OpenACC privatization level} "TODO" { target *-*-* } .-6 }
! { dg-note {variable 'transfer\.[0-9]+' declared in block is candidate for adjusting OpenACC privatization level} "TODO" { target *-*-* } .-7 }
! { dg-note {variable 'parm\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-8 }
+ ! { dg-note {variable 'p\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-9 }
! not mapped yet, so it will be equal to the host pointer.
if (transfer(c_loc(p), host_p) /= host_p) stop 7
if (transfer(c_loc(parr), host_parr) /= host_parr) stop 8
@@ -93,6 +94,7 @@ subroutine foo (p2, parr, host_p, host_parr, cond)
! { dg-note {variable 'D\.[0-9]+' declared in block is candidate for adjusting OpenACC privatization level} "TODO" { target *-*-* } .-6 }
! { dg-note {variable 'transfer\.[0-9]+' declared in block is candidate for adjusting OpenACC privatization level} "TODO" { target *-*-* } .-7 }
! { dg-note {variable 'parm\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-8 }
+ ! { dg-note {variable 'p\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-9 }
#if ACC_MEM_SHARED
if (transfer(c_loc(p), host_p) /= host_p) stop 15
if (transfer(c_loc(parr), host_parr) /= host_parr) stop 16
@@ -112,6 +114,7 @@ subroutine foo (p2, parr, host_p, host_parr, cond)
! { dg-note {variable 'parm\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-6 }
! { dg-note {variable 'D\.[0-9]+' declared in block is candidate for adjusting OpenACC privatization level} "TODO" { target *-*-* } .-7 }
! { dg-note {variable 'transfer\.[0-9]+' declared in block is candidate for adjusting OpenACC privatization level} "TODO" { target *-*-* } .-8 }
+ ! { dg-note {variable 'p\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-9 }
#if ACC_MEM_SHARED
if (transfer(c_loc(p), host_p) /= host_p) stop 19
if (transfer(c_loc(parr), host_parr) /= host_parr) stop 20
@@ -131,6 +134,7 @@ subroutine foo (p2, parr, host_p, host_parr, cond)
! { dg-note {variable 'parm\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-6 }
! { dg-note {variable 'D\.[0-9]+' declared in block is candidate for adjusting OpenACC privatization level} "TODO" { target *-*-* } .-7 }
! { dg-note {variable 'transfer\.[0-9]+' declared in block is candidate for adjusting OpenACC privatization level} "TODO" { target *-*-* } .-8 }
+ ! { dg-note {variable 'p\.[0-9]+' declared in block isn't candidate for adjusting OpenACC privatization level: not addressable} "" { target *-*-* } .-9 }
#if ACC_MEM_SHARED
if (transfer(c_loc(p), host_p) /= host_p) stop 23
if (transfer(c_loc(parr), host_parr) /= host_parr) stop 24