diff options
| author | Tobias Burnus <tobias@codesourcery.com> | 2022-03-01 16:35:08 +0100 |
|---|---|---|
| committer | Tobias Burnus <tobias@codesourcery.com> | 2022-03-01 16:35:08 +0100 |
| commit | 98961d3a0ccb02d7d54d2d4dd07cca75473d685a (patch) | |
| tree | a53a4e5947f46989cec305eaf1fbc268d1fa2cfc | |
| parent | 6d5663d17460d668d285a2b9552ae5b071f92584 (diff) | |
Fortran/OpenMP: Support mapping of DT with allocatable components
This commit: OG11 version.
GCC 12/mainline submission:
https://gcc.gnu.org/pipermail/gcc-patches/2022-March/591075.html
gcc/fortran/ChangeLog:
* class.c (finalization_scalarizer): Mark syms as artificial.
(generate_callback_wrapper): New.
(gfc_find_derived_vtab): Call it, add _callback comp.
* f95-lang.c (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.c (select_type_set_tmp): Propagate allocatable property.
* module.c (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.c (resolve_omp_clauses): Accept DT with alloc comps.
* resolve.c (gfc_resolve_formal_arglist, gfc_resolve_intrinsic,
resolve_fl_procedure, resolve_types): Permit some violations
for internal code.
* trans-array.c (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.c (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.c (gfc_conv_intrinsic_sizeof,
gfc_conv_associated): Fix class and comp-ref handling.
(conv_isocbinding_function): Remove buggy code.
* trans-openmp.c (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.c (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.c (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.c (expand_omp_target): Handle dynamic-size
addr/sizes/kinds arrays.
* omp-low.c (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.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/gomp/map-alloc-comp-1.f90: Remove sorry dg-error.
27 files changed, 3741 insertions, 144 deletions
diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 93118ad3455..26f9a7e4e93 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -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; @@ -2248,6 +2252,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. */ @@ -2430,6 +2937,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) @@ -2605,13 +3114,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); diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c index a4271982786..d23ad3a7520 100644 --- a/gcc/fortran/f95-lang.c +++ b/gcc/fortran/f95-lang.c @@ -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 diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index a18ed407bc6..30f55b36a84 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -3790,6 +3790,7 @@ void gfc_free_wait (gfc_wait *); bool gfc_resolve_wait (gfc_wait *); /* module.c */ +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); @@ -3853,6 +3854,13 @@ bool gfc_invalid_null_arg (gfc_expr *); /* class.c */ +#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 *); diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 53a575e616e..d481091b75a 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -6364,6 +6364,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 diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 089453caa03..b1b1663243b 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -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. */ @@ -6568,7 +6568,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; @@ -6639,16 +6639,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. */ @@ -6747,7 +6748,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) @@ -6781,7 +6782,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) \ @@ -6831,6 +6834,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. */ @@ -7240,7 +7250,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; diff --git a/gcc/fortran/openmp.c b/gcc/fortran/openmp.c index cd6fc759583..90d9b486e29 100644 --- a/gcc/fortran/openmp.c +++ b/gcc/fortran/openmp.c @@ -7094,13 +7094,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) { diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index f4e231829b9..8120f04c568 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -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, @@ -1873,7 +1874,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 " @@ -13361,7 +13363,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); @@ -17448,7 +17450,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); diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 3eb9a177817..0d637162509 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -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); @@ -8216,7 +8218,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) { @@ -8226,20 +8229,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; @@ -8256,8 +8260,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)); @@ -8298,7 +8302,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)); @@ -8790,7 +8795,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, diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 781ab87ee64..43404702544 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -203,6 +203,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 @@ -382,7 +383,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) /* The size field is returned as an array index type. Therefore treat it and only it specially. */ @@ -419,6 +420,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 @@ -9487,7 +9491,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; } @@ -9545,6 +9550,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); diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 6bda0f82114..288ad772cb1 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -8088,12 +8088,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 @@ -8103,7 +8109,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 { @@ -8864,13 +8870,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))) @@ -9490,13 +9496,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); diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 48d0c3f3047..27cfa4008f1 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -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__ @@ -327,22 +336,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; @@ -361,7 +373,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; @@ -439,7 +451,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; @@ -579,7 +591,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) @@ -703,7 +715,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); @@ -756,7 +768,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), @@ -893,7 +905,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); @@ -952,7 +964,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), @@ -997,7 +1009,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. */ @@ -1019,7 +1031,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); @@ -1134,7 +1146,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), @@ -1381,7 +1393,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); @@ -1401,7 +1413,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; @@ -1509,6 +1521,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 (DECL_P (decl) && POINTER_TYPE_P (TREE_TYPE (decl))) { if (!gfc_omp_privatize_by_reference (decl) @@ -1517,7 +1530,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); @@ -1530,14 +1543,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; @@ -1554,10 +1567,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))) @@ -1600,7 +1613,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); @@ -1613,15 +1626,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, @@ -1631,7 +1662,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); @@ -1648,11 +1679,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)); @@ -1663,9 +1696,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)); @@ -1674,11 +1710,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); @@ -1701,6 +1756,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; + TREE_NO_WARNING (field) = 1; + + 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; + TREE_NO_WARNING (field2) = 1; + + 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; + TREE_NO_WARNING (field) = 1; + + field2 = build_decl (UNKNOWN_LOCATION, FIELD_DECL, + get_identifier ("offset_data"), size_type_node); + DECL_CHAIN (field) = field2; + DECL_CONTEXT (field2) = decl; + TREE_NO_WARNING (field2) = 1; + + field = build_decl (UNKNOWN_LOCATION, FIELD_DECL, + get_identifier ("offset"), size_type_node); + DECL_CHAIN (field2) = field; + DECL_CONTEXT (field) = decl; + TREE_NO_WARNING (field) = 1; + + field2 = build_decl (UNKNOWN_LOCATION, FIELD_DECL, + get_identifier ("flags"), short_unsigned_type_node); + DECL_CHAIN (field) = field2; + DECL_CONTEXT (field2) = decl; + TREE_NO_WARNING (field2) = 1; + + field = build_decl (UNKNOWN_LOCATION, FIELD_DECL, + get_identifier ("detach"), boolean_type_node); + DECL_CHAIN (field2) = field; + DECL_CONTEXT (field) = decl; + TREE_NO_WARNING (field) = 1; + + 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.' @@ -2394,6 +3732,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))); @@ -3195,7 +4545,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 @@ -3271,13 +4622,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 @@ -3343,6 +4721,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 @@ -3381,7 +4784,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; @@ -3415,6 +4818,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) @@ -3486,6 +4905,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); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index ecbad5bf7e6..63ac048d213 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1433,8 +1433,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, @@ -2695,9 +2703,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 + && gfc_str_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 @@ -2796,16 +2805,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 + && gfc_str_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); } @@ -3454,15 +3473,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; diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 62af8e76812..a4398821ccd 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -437,6 +437,7 @@ tree gfc_class_vtab_extends_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); @@ -825,6 +826,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); @@ -996,6 +1001,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 diff --git a/gcc/langhooks-def.h b/gcc/langhooks-def.h index 8b744d96fb2..fc90018e08e 100644 --- a/gcc/langhooks-def.h +++ b/gcc/langhooks-def.h @@ -82,6 +82,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); @@ -266,6 +270,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 @@ -299,6 +306,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, \ diff --git a/gcc/langhooks.c b/gcc/langhooks.c index e211efc63f0..2f7295ce3ec 100644 --- a/gcc/langhooks.c +++ b/gcc/langhooks.c @@ -614,6 +614,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. */ diff --git a/gcc/langhooks.h b/gcc/langhooks.h index 1b417a01a4e..302425e0bf9 100644 --- a/gcc/langhooks.h +++ b/gcc/langhooks.h @@ -296,6 +296,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); diff --git a/gcc/omp-expand.c b/gcc/omp-expand.c index 5da8f2034c1..943c86a5c25 100644 --- a/gcc/omp-expand.c +++ b/gcc/omp-expand.c @@ -9898,8 +9898,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; @@ -10215,7 +10216,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)); @@ -10223,6 +10224,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; diff --git a/gcc/omp-low.c b/gcc/omp-low.c index 5a211e6555f..eea258952ad 100644 --- a/gcc/omp-low.c +++ b/gcc/omp-low.c @@ -823,7 +823,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 @@ -1352,7 +1355,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); } static void @@ -1402,6 +1407,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 @@ -1775,6 +1781,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 @@ -2211,6 +2219,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. */ @@ -13103,6 +13123,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)) { @@ -13176,6 +13201,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)) { @@ -13240,6 +13267,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 @@ -13485,18 +13522,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; @@ -13504,13 +13554,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); @@ -13541,6 +13643,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 @@ -14072,23 +14192,65 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx) gimple_omp_target_set_data_arg (stmt, nt); } - 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)) { @@ -14108,7 +14270,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)); } @@ -14121,11 +14294,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); diff --git a/gcc/testsuite/gfortran.dg/c_loc_test_22.f90 b/gcc/testsuite/gfortran.dg/c_loc_test_22.f90 index 9c40b26d830..b35ed7cbb30 100644 --- a/gcc/testsuite/gfortran.dg/c_loc_test_22.f90 +++ b/gcc/testsuite/gfortran.dg/c_loc_test_22.f90 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/finalize_21.f90 b/gcc/testsuite/gfortran.dg/finalize_21.f90 index 5a8fec3d139..1c1b0d2839a 100644 --- a/gcc/testsuite/gfortran.dg/finalize_21.f90 +++ b/gcc/testsuite/gfortran.dg/finalize_21.f90 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/gomp/map-alloc-comp-1.f90 b/gcc/testsuite/gfortran.dg/gomp/map-alloc-comp-1.f90 index 0c4429677bd..f48addcbcf5 100644 --- a/gcc/testsuite/gfortran.dg/gomp/map-alloc-comp-1.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/map-alloc-comp-1.f90 @@ -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 diff --git a/libgomp/testsuite/libgomp.fortran/allocatable-comp.f90 b/libgomp/testsuite/libgomp.fortran/allocatable-comp.f90 new file mode 100644 index 00000000000..383ecba98b4 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/allocatable-comp.f90 @@ -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 diff --git a/libgomp/testsuite/libgomp.fortran/map-alloc-comp-3.f90 b/libgomp/testsuite/libgomp.fortran/map-alloc-comp-3.f90 new file mode 100644 index 00000000000..9d48c7ca59d --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/map-alloc-comp-3.f90 @@ -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 diff --git a/libgomp/testsuite/libgomp.fortran/map-alloc-comp-4.f90 b/libgomp/testsuite/libgomp.fortran/map-alloc-comp-4.f90 new file mode 100644 index 00000000000..fb9859d99a4 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/map-alloc-comp-4.f90 @@ -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 diff --git a/libgomp/testsuite/libgomp.fortran/map-alloc-comp-5.f90 b/libgomp/testsuite/libgomp.fortran/map-alloc-comp-5.f90 new file mode 100644 index 00000000000..b2e36b2a4b8 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/map-alloc-comp-5.f90 @@ -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 diff --git a/libgomp/testsuite/libgomp.fortran/map-alloc-comp-6.f90 b/libgomp/testsuite/libgomp.fortran/map-alloc-comp-6.f90 new file mode 100644 index 00000000000..9bc0008f54c --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/map-alloc-comp-6.f90 @@ -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 diff --git a/libgomp/testsuite/libgomp.fortran/map-alloc-comp-7.f90 b/libgomp/testsuite/libgomp.fortran/map-alloc-comp-7.f90 new file mode 100644 index 00000000000..2c9313e89c5 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/map-alloc-comp-7.f90 @@ -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 |