diff options
| author | Tobias Burnus <tobias@codesourcery.com> | 2023-12-08 15:18:25 +0100 |
|---|---|---|
| committer | Tobias Burnus <tobias@codesourcery.com> | 2023-12-08 15:18:25 +0100 |
| commit | d4b6d147920b93297e621124a99ed01e7e310d92 (patch) | |
| tree | 330b3935af3a4ad4593ca48db70d71b1672a5dc9 | |
| parent | 47575ec9edcd3078f066aa54ba428420be796bef (diff) | |
OpenMP/Fortran: Implement omp allocators/allocate for ptr/allocatables
This commit adds -fopenmp-allocators which enables support for
'omp allocators' and 'omp allocate' that are associated with a Fortran
allocate-stmt. If such a construct is encountered, an error is shown,
unless the -fopenmp-allocators flag is present.
With -fopenmp -fopenmp-allocators, those constructs get turned into
GOMP_alloc allocations, while -fopenmp-allocators (also without -fopenmp)
ensures deallocation and reallocation (via intrinsic assignments) are
properly directed to GOMP_free/omp_realloc - while normal Fortran
allocations are processed by free/realloc.
In order to distinguish a 'malloc'ed from a 'GOMP_alloc'ed memory, the
version field of the Fortran array discriptor is (mis)used: 0 indicates
the normal Fortran allocation while 1 denotes GOMP_alloc. For scalars,
there is record keeping in libgomp: GOMP_add_alloc(ptr) will add the
pointer address to a splay_tree while GOMP_is_alloc(ptr) will return
true it was previously added but also removes it from the list.
Besides Fortran FE work, BUILT_IN_GOMP_REALLOC is no part of
omp-builtins.def and libgomp gains the mentioned two new function.
gcc/ChangeLog:
* builtin-types.def (BT_FN_PTR_PTR_SIZE_PTRMODE_PTRMODE): New.
* omp-builtins.def (BUILT_IN_GOMP_REALLOC): New.
* builtins.cc (builtin_fnspec): Handle it.
* gimple-ssa-warn-access.cc (fndecl_alloc_p,
matching_alloc_calls_p): Likewise.
* gimple.cc (nonfreeing_call_p): Likewise.
* predict.cc (expr_expected_value_1): Likewise.
* tree-ssa-ccp.cc (evaluate_stmt): Likewise.
* tree.cc (fndecl_dealloc_argno): Likewise.
gcc/fortran/ChangeLog:
* dump-parse-tree.cc (show_omp_node): Handle EXEC_OMP_ALLOCATE
and EXEC_OMP_ALLOCATORS.
* f95-lang.cc (ATTR_ALLOC_WARN_UNUSED_RESULT_SIZE_2_NOTHROW_LIST):
Add 'ECF_LEAF | ECF_MALLOC' to existing 'ECF_NOTHROW'.
(ATTR_ALLOC_WARN_UNUSED_RESULT_SIZE_2_NOTHROW_LEAF_LIST): Define.
* gfortran.h (gfc_omp_clauses): Add contained_in_target_construct.
* invoke.texi (-fopenacc, -fopenmp): Update based on C version.
(-fopenmp-simd): New, based on C version.
(-fopenmp-allocators): New.
* lang.opt (fopenmp-allocators): Add.
* openmp.cc (resolve_omp_clauses): For allocators/allocate directive,
add target and no dynamic_allocators diagnostic and more invalid
diagnostic.
* parse.cc (decode_omp_directive): Set contains_teams_construct.
* trans-array.h (gfc_array_allocate): Update prototype.
(gfc_conv_descriptor_version): New prototype.
* trans-decl.cc (gfc_init_default_dt): Fix comment.
* trans-array.cc (gfc_conv_descriptor_version): New.
(gfc_array_allocate): Support GOMP_alloc allocation.
(gfc_alloc_allocatable_for_assignment, structure_alloc_comps):
Handle GOMP_free/omp_realloc as needed.
* trans-expr.cc (gfc_conv_procedure_call): Likewise.
(alloc_scalar_allocatable_for_assignment): Likewise.
* trans-intrinsic.cc (conv_intrinsic_move_alloc): Likewise.
* trans-openmp.cc (gfc_trans_omp_allocators,
gfc_trans_omp_directive): Handle allocators/allocate directive.
(gfc_omp_call_add_alloc, gfc_omp_call_is_alloc): New.
* trans-stmt.h (gfc_trans_allocate): Update prototype.
* trans-stmt.cc (gfc_trans_allocate): Support GOMP_alloc.
* trans-types.cc (gfc_get_dtype_rank_type): Set version field.
* trans.cc (gfc_allocate_using_malloc, gfc_allocate_allocatable):
Update to handle GOMP_alloc.
(gfc_deallocate_with_status, gfc_deallocate_scalar_with_status):
Handle GOMP_free.
(trans_code): Update call.
* trans.h (gfc_allocate_allocatable, gfc_allocate_using_malloc):
Update prototype.
(gfc_omp_call_add_alloc, gfc_omp_call_is_alloc): New prototype.
* types.def (BT_FN_PTR_PTR_SIZE_PTRMODE_PTRMODE): New.
libgomp/ChangeLog:
* allocator.c (struct fort_alloc_splay_tree_key_s,
fort_alloc_splay_compare, GOMP_add_alloc, GOMP_is_alloc): New.
* libgomp.h: Define splay_tree_static for 'reverse' splay tree.
* libgomp.map (GOMP_5.1.2): New; add GOMP_add_alloc and
GOMP_is_alloc; move GOMP_target_map_indirect_ptr from ...
(GOMP_5.1.1): ... here.
* libgomp.texi (Impl. Status, Memory management): Update for
allocators/allocate directives.
* splay-tree.c: Handle splay_tree_static define to declare all
functions as static.
(splay_tree_lookup_node): New.
* splay-tree.h: Handle splay_tree_decl_only define.
(splay_tree_lookup_node): New prototype.
* target.c: Define splay_tree_static for 'reverse'.
* testsuite/libgomp.fortran/allocators-1.f90: New test.
* testsuite/libgomp.fortran/allocators-2.f90: New test.
* testsuite/libgomp.fortran/allocators-3.f90: New test.
* testsuite/libgomp.fortran/allocators-4.f90: New test.
* testsuite/libgomp.fortran/allocators-5.f90: New test.
gcc/testsuite/ChangeLog:
* gfortran.dg/gomp/allocate-14.f90: Add coarray and
not-listed tests.
* gfortran.dg/gomp/allocate-5.f90: Remove sorry dg-message.
* gfortran.dg/bind_c_array_params_2.f90: Update expected
dump for dtype '.version=0'.
* gfortran.dg/gomp/allocate-16.f90: New test.
* gfortran.dg/gomp/allocators-3.f90: New test.
* gfortran.dg/gomp/allocators-4.f90: New test.
45 files changed, 1113 insertions, 116 deletions
diff --git a/gcc/builtin-types.def b/gcc/builtin-types.def index 43381bc8949..183ef62bad2 100644 --- a/gcc/builtin-types.def +++ b/gcc/builtin-types.def @@ -840,6 +840,8 @@ DEF_FUNCTION_TYPE_4 (BT_FN_PTR_PTR_CONST_PTR_SIZE_SIZE, BT_PTR, BT_PTR, BT_CONST_PTR, BT_SIZE, BT_SIZE) DEF_FUNCTION_TYPE_4 (BT_FN_PTR_PTR_INT_SIZE_SIZE, BT_PTR, BT_PTR, BT_INT, BT_SIZE, BT_SIZE) +DEF_FUNCTION_TYPE_4 (BT_FN_PTR_PTR_SIZE_PTRMODE_PTRMODE, + BT_PTR, BT_PTR, BT_SIZE, BT_PTRMODE, BT_PTRMODE) DEF_FUNCTION_TYPE_4 (BT_FN_UINT_UINT_UINT_UINT_UINT, BT_UINT, BT_UINT, BT_UINT, BT_UINT, BT_UINT) DEF_FUNCTION_TYPE_4 (BT_FN_UINT_UINT_UINT_UINT_UINTPTR, diff --git a/gcc/builtins.cc b/gcc/builtins.cc index afa9be51443..38b0acff131 100644 --- a/gcc/builtins.cc +++ b/gcc/builtins.cc @@ -12410,6 +12410,7 @@ builtin_fnspec (tree callee) return ".cO "; /* Realloc serves both as allocation point and deallocation point. */ case BUILT_IN_REALLOC: + case BUILT_IN_GOMP_REALLOC: return ".Cw "; case BUILT_IN_GAMMA_R: case BUILT_IN_GAMMAF_R: diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc index cc4846e5d74..ecf71036444 100644 --- a/gcc/fortran/dump-parse-tree.cc +++ b/gcc/fortran/dump-parse-tree.cc @@ -2241,6 +2241,8 @@ show_omp_node (int level, gfc_code *c) case EXEC_OACC_CACHE: case EXEC_OACC_ENTER_DATA: case EXEC_OACC_EXIT_DATA: + case EXEC_OMP_ALLOCATE: + case EXEC_OMP_ALLOCATORS: case EXEC_OMP_ASSUME: case EXEC_OMP_CANCEL: case EXEC_OMP_CANCELLATION_POINT: diff --git a/gcc/fortran/f95-lang.cc b/gcc/fortran/f95-lang.cc index 32fddcde957..539bc271e78 100644 --- a/gcc/fortran/f95-lang.cc +++ b/gcc/fortran/f95-lang.cc @@ -566,7 +566,9 @@ gfc_builtin_function (tree decl) #define ATTR_NOTHROW_LIST (ECF_NOTHROW) #define ATTR_CONST_NOTHROW_LIST (ECF_NOTHROW | ECF_CONST) #define ATTR_ALLOC_WARN_UNUSED_RESULT_SIZE_2_NOTHROW_LIST \ - (ECF_NOTHROW) + (ECF_NOTHROW | ECF_LEAF | ECF_MALLOC) +#define ATTR_ALLOC_WARN_UNUSED_RESULT_SIZE_2_NOTHROW_LEAF_LIST \ + (ECF_NOTHROW | ECF_LEAF) #define ATTR_COLD_NORETURN_NOTHROW_LEAF_LIST \ (ECF_COLD | ECF_NORETURN | \ ECF_NOTHROW | ECF_LEAF) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index a77441f38e7..28569d07e71 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1579,6 +1579,7 @@ typedef struct gfc_omp_clauses unsigned grainsize_strict:1, num_tasks_strict:1, compare:1, weak:1; unsigned non_rectangular:1, order_concurrent:1; unsigned contains_teams_construct:1, target_first_st_is_teams:1; + unsigned contained_in_target_construct:1; ENUM_BITFIELD (gfc_omp_sched_kind) sched_kind:3; ENUM_BITFIELD (gfc_omp_device_type) device_type:2; ENUM_BITFIELD (gfc_omp_memorder) memorder:3; diff --git a/gcc/fortran/invoke.texi b/gcc/fortran/invoke.texi index 2f1d1f28429..7523d759532 100644 --- a/gcc/fortran/invoke.texi +++ b/gcc/fortran/invoke.texi @@ -126,8 +126,9 @@ by type. Explanations are in the following sections. -ffree-form -ffree-line-length-@var{n} -ffree-line-length-none -fimplicit-none -finteger-4-integer-8 -fmax-identifier-length -fmodule-private -ffixed-form -fno-range-check -fopenacc -fopenmp --freal-4-real-10 -freal-4-real-16 -freal-4-real-8 -freal-8-real-10 --freal-8-real-16 -freal-8-real-4 -std=@var{std} -ftest-forall-temp +-fopenmp-allocators -fopenmp-simd -freal-4-real-10 -freal-4-real-16 +-freal-4-real-8 -freal-8-real-10 -freal-8-real-16 -freal-8-real-4 +-std=@var{std} -ftest-forall-temp } @item Preprocessing Options @@ -410,26 +411,64 @@ Specify that no implicit typing is allowed, unless overridden by explicit Enable the Cray pointer extension, which provides C-like pointer functionality. -@opindex @code{fopenacc} -@cindex OpenACC + +@opindex fopenacc +@cindex OpenACC accelerator programming @item -fopenacc -Enable the OpenACC extensions. This includes OpenACC @code{!$acc} -directives in free form and @code{c$acc}, @code{*$acc} and -@code{!$acc} directives in fixed form, @code{!$} conditional -compilation sentinels in free form and @code{c$}, @code{*$} and -@code{!$} sentinels in fixed form, and when linking arranges for the -OpenACC runtime library to be linked in. - -@opindex @code{fopenmp} -@cindex OpenMP +Enable handling of OpenACC directives @samp{!$acc} in free-form Fortran and +@samp{!$acc}, @samp{c$acc} and @samp{*$acc} in fixed-form Fortran. When +@option{-fopenacc} is specified, the compiler generates accelerated code +according to the OpenACC Application Programming Interface v2.6 +@w{@uref{https://www.openacc.org}}. This option implies @option{-pthread}, +and thus is only supported on targets that have support for @option{-pthread}. +The option @option{-fopenacc} implies @option{-frecursive}. + +@opindex fopenmp +@cindex OpenMP parallel @item -fopenmp -Enable the OpenMP extensions. This includes OpenMP @code{!$omp} directives -in free form -and @code{c$omp}, @code{*$omp} and @code{!$omp} directives in fixed form, -@code{!$} conditional compilation sentinels in free form -and @code{c$}, @code{*$} and @code{!$} sentinels in fixed form, -and when linking arranges for the OpenMP runtime library to be linked -in. The option @option{-fopenmp} implies @option{-frecursive}. +Enable handling of OpenMP directives @samp{!$omp} in Fortran. It +additionally enables the conditional compilation sentinel @samp{!$} in +Fortran. In fixed source form Fortran, the sentinels can also start with +@samp{c} or @samp{*}. When @option{-fopenmp} is specified, the +compiler generates parallel code according to the OpenMP Application +Program Interface v4.5 @w{@uref{https://www.openmp.org}}. This option +implies @option{-pthread}, and thus is only supported on targets that +have support for @option{-pthread}. @option{-fopenmp} implies +@option{-fopenmp-simd} and @option{-frecursive}. + +@opindex fopenmp-allocators +@cindex OpenMP Allocators +@item -fopenmp-allocators +Enables handling of allocation, reallocation and deallocation of Fortran +allocatable and pointer variables that are allocated using the +@samp{!$omp allocators} and @samp{!$omp allocate} constructs. Files +containing either directive have to be compiled with this option in addition +to @option{-fopenmp}. Additionally, all files that might deallocate or +reallocate a variable that has been allocated with an OpenMP allocator +have to be compiled with this option. This includes intrinsic assignment +to allocatable variables when reallocation may occur and deallocation +due to either of the following: end of scope, explicit deallocation, +@samp{intent(out)}, deallocation of allocatable components etc. +Files not changing the allocation status or only for components of +a derived type that have not been allocated using those two directives +do not need to be compiled with this option. Nor do files that handle +such variables after they have been deallocated or allocated by the +normal Fortran allocator. + +@opindex fopenmp-simd +@cindex OpenMP SIMD +@cindex SIMD +@item -fopenmp-simd +Enable handling of OpenMP's @code{simd}, @code{declare simd}, +@code{declare reduction}, @code{assume}, @code{ordered}, @code{scan} +and @code{loop} directive, and of combined or composite directives with +@code{simd} as constituent with @code{!$omp} in Fortran. It additionally +enables the conditional compilation sentinel @samp{!$} in Fortran. In +fixed source form Fortran, the sentinels can also start with @samp{c} or +@samp{*}. Other OpenMP directives are ignored. Unless @option{-fopenmp} +is additionally specified, the @code{loop} region binds to the current task +region, independent of the specified @code{bind} clause. + @opindex @code{frange-check} @item -fno-range-check diff --git a/gcc/fortran/lang.opt b/gcc/fortran/lang.opt index adcfc280b5a..7c301431cbc 100644 --- a/gcc/fortran/lang.opt +++ b/gcc/fortran/lang.opt @@ -716,6 +716,10 @@ fopenmp-simd Fortran ; Documented in C +fopenmp-allocators +Fortran Var(flag_openmp_allocators) +Handle OpenMP allocators for allocatables and pointers. + fpack-derived Fortran Var(flag_pack_derived) Try to lay out derived types as compactly as possible. diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc index 794df19a4d1..251da667236 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -7424,6 +7424,9 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, if (omp_clauses == NULL) return; + if (ns == NULL) + ns = gfc_current_ns; + if (omp_clauses->orderedc && omp_clauses->orderedc < omp_clauses->collapse) gfc_error ("ORDERED clause parameter is less than COLLAPSE at %L", &code->loc); @@ -7657,23 +7660,22 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, && n->sym->result == n->sym && n->sym->attr.function) { - if (gfc_current_ns->proc_name == n->sym - || (gfc_current_ns->parent - && gfc_current_ns->parent->proc_name == n->sym)) + if (ns->proc_name == n->sym + || (ns->parent && ns->parent->proc_name == n->sym)) continue; - if (gfc_current_ns->proc_name->attr.entry_master) + if (ns->proc_name->attr.entry_master) { - gfc_entry_list *el = gfc_current_ns->entries; + gfc_entry_list *el = ns->entries; for (; el; el = el->next) if (el->sym == n->sym) break; if (el) continue; } - if (gfc_current_ns->parent - && gfc_current_ns->parent->proc_name->attr.entry_master) + if (ns->parent + && ns->parent->proc_name->attr.entry_master) { - gfc_entry_list *el = gfc_current_ns->parent->entries; + gfc_entry_list *el = ns->parent->entries; for (; el; el = el->next) if (el->sym == n->sym) break; @@ -7973,24 +7975,120 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses, && code->block->next->op == EXEC_ALLOCATE) { gfc_alloc *a; + gfc_omp_namelist *n_null = NULL; + bool missing_allocator = false; + gfc_symbol *missing_allocator_sym = NULL; for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) { + if (n->u2.allocator == NULL) + { + if (!missing_allocator_sym) + missing_allocator_sym = n->sym; + missing_allocator = true; + } if (n->sym == NULL) - continue; + { + n_null = n; + continue; + } if (n->sym->attr.codimension) gfc_error ("Unexpected coarray %qs in %<allocate%> at %L", n->sym->name, &n->where); for (a = code->block->next->ext.alloc.list; a; a = a->next) if (a->expr->expr_type == EXPR_VARIABLE && a->expr->symtree->n.sym == n->sym) - break; + { + gfc_ref *ref; + for (ref = a->expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + break; + if (ref == NULL) + break; + } if (a == NULL) gfc_error ("%qs specified in %<allocate%> at %L but not " "in the associated ALLOCATE statement", n->sym->name, &n->where); } - } + /* If there is an ALLOCATE directive without list argument, a + namelist with its allocator/align clauses and n->sym = NULL is + created during parsing; here, we add all not otherwise specified + items from the Fortran allocate to that list. + For an ALLOCATORS directive, not listed items use the normal + Fortran way. + The behavior of an ALLOCATE directive that does not list all + arguments but there is no directive without list argument is not + well specified. Thus, we reject such code below. In OpenMP 5.2 + the executable ALLOCATE directive is deprecated and in 6.0 + deleted such that no spec clarification is to be expected. */ + for (a = code->block->next->ext.alloc.list; a; a = a->next) + if (a->expr->expr_type == EXPR_VARIABLE) + { + for (n = omp_clauses->lists[OMP_LIST_ALLOCATE]; n; n = n->next) + if (a->expr->symtree->n.sym == n->sym) + { + gfc_ref *ref; + for (ref = a->expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + break; + if (ref == NULL) + break; + } + if (n == NULL && n_null == NULL) + { + /* OK for ALLOCATORS but for ALLOCATE: Unspecified whether + that should use the default allocator of OpenMP or the + Fortran allocator. Thus, just reject it. */ + if (code->op == EXEC_OMP_ALLOCATE) + gfc_error ("%qs listed in %<allocate%> statement at %L " + "but it is neither explicitly in listed in " + "the %<!$OMP ALLOCATE%> directive nor exists" + " a directive without argument list", + a->expr->symtree->n.sym->name, + &a->expr->where); + break; + } + if (n == NULL) + { + if (a->expr->symtree->n.sym->attr.codimension) + gfc_error ("Unexpected coarray %qs in %<allocate%> at " + "%L, implicitly listed in %<!$OMP ALLOCATE%>" + " at %L", a->expr->symtree->n.sym->name, + &a->expr->where, &n_null->where); + break; + } + } + gfc_namespace *prog_unit = ns; + while (prog_unit->parent) + prog_unit = prog_unit->parent; + gfc_namespace *fn_ns = ns; + while (fn_ns) + { + if (ns->proc_name + && (ns->proc_name->attr.subroutine + || ns->proc_name->attr.function)) + break; + fn_ns = fn_ns->parent; + } + if (missing_allocator + && !(prog_unit->omp_requires & OMP_REQ_DYNAMIC_ALLOCATORS) + && ((fn_ns && fn_ns->proc_name->attr.omp_declare_target) + || omp_clauses->contained_in_target_construct)) + { + if (code->op == EXEC_OMP_ALLOCATORS) + gfc_error ("ALLOCATORS directive at %L inside a target region " + "must specify an ALLOCATOR modifier for %qs", + &code->loc, missing_allocator_sym->name); + else if (missing_allocator_sym) + gfc_error ("ALLOCATE directive at %L inside a target region " + "must specify an ALLOCATOR clause for %qs", + &code->loc, missing_allocator_sym->name); + else + gfc_error ("ALLOCATE directive at %L inside a target region " + "must specify an ALLOCATOR clause", &code->loc); + } + } } /* OpenACC reductions. */ diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index abd3a424f38..c0eb0575a90 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -1364,6 +1364,8 @@ decode_omp_directive (void) prog_unit->omp_target_seen = true; break; } + case ST_OMP_ALLOCATE_EXEC: + case ST_OMP_ALLOCATORS: case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: case ST_OMP_TEAMS_DISTRIBUTE_SIMD: @@ -1386,7 +1388,10 @@ decode_omp_directive (void) case EXEC_OMP_TARGET_PARALLEL_DO_SIMD: case EXEC_OMP_TARGET_PARALLEL_LOOP: case EXEC_OMP_TARGET_SIMD: - stk->tail->ext.omp_clauses->contains_teams_construct = 1; + if (ret == ST_OMP_ALLOCATE_EXEC || ret == ST_OMP_ALLOCATORS) + new_st.ext.omp_clauses->contained_in_target_construct = 1; + else + stk->tail->ext.omp_clauses->contains_teams_construct = 1; break; default: break; diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc index 82f60a656f3..2930406a8e4 100644 --- a/gcc/fortran/trans-array.cc +++ b/gcc/fortran/trans-array.cc @@ -363,6 +363,21 @@ gfc_conv_descriptor_rank (tree desc) } +tree +gfc_conv_descriptor_version (tree desc) +{ + tree tmp; + tree dtype; + + dtype = gfc_conv_descriptor_dtype (desc); + tmp = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (dtype)), GFC_DTYPE_VERSION); + gcc_assert (tmp != NULL_TREE + && TREE_TYPE (tmp) == integer_type_node); + return fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), + dtype, tmp, NULL_TREE); +} + + /* Return the element length from the descriptor dtype field. */ tree @@ -6196,7 +6211,7 @@ bool gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, tree errlen, tree label_finish, tree expr3_elem_size, tree *nelems, gfc_expr *expr3, tree e3_arr_desc, - bool e3_has_nodescriptor) + bool e3_has_nodescriptor, gfc_omp_namelist *omp_alloc) { tree tmp; tree pointer; @@ -6218,6 +6233,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, gfc_ref *ref, *prev_ref = NULL, *coref; bool allocatable, coarray, dimension, alloc_w_e3_arr_spec = false, non_ulimate_coarray_ptr_comp; + tree omp_cond = NULL_TREE, omp_alt_alloc = NULL_TREE; ref = expr->ref; @@ -6368,7 +6384,11 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, token = gfc_build_addr_expr (NULL_TREE, token); } else - pointer = gfc_conv_descriptor_data_get (se->expr); + { + pointer = gfc_conv_descriptor_data_get (se->expr); + if (omp_alloc) + omp_cond = boolean_true_node; + } STRIP_NOPS (pointer); if (allocatable) @@ -6384,18 +6404,66 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, gfc_start_block (&elseblock); + tree succ_add_expr = NULL_TREE; + if (omp_cond) + { + tree align, alloc, sz; + gfc_se se2; + if (omp_alloc->u2.allocator) + { + gfc_init_se (&se2, NULL); + gfc_conv_expr (&se2, omp_alloc->u2.allocator); + gfc_add_block_to_block (&elseblock, &se2.pre); + alloc = gfc_evaluate_now (se2.expr, &elseblock); + gfc_add_block_to_block (&elseblock, &se2.post); + } + else + alloc = build_zero_cst (ptr_type_node); + tmp = TREE_TYPE (TREE_TYPE (pointer)); + if (tmp == void_type_node) + tmp = gfc_typenode_for_spec (&expr->ts, 0); + if (omp_alloc->u.align) + { + gfc_init_se (&se2, NULL); + gfc_conv_expr (&se2, omp_alloc->u.align); + gcc_assert (CONSTANT_CLASS_P (se2.expr) + && se2.pre.head == NULL + && se2.post.head == NULL); + align = build_int_cst (size_type_node, + MAX (tree_to_uhwi (se2.expr), + TYPE_ALIGN_UNIT (tmp))); + } + else + align = build_int_cst (size_type_node, TYPE_ALIGN_UNIT (tmp)); + sz = fold_build2_loc (input_location, MAX_EXPR, size_type_node, + fold_convert (size_type_node, size), + build_int_cst (size_type_node, 1)); + omp_alt_alloc = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC); + DECL_ATTRIBUTES (omp_alt_alloc) + = tree_cons (get_identifier ("omp allocator"), + build_tree_list (NULL_TREE, alloc), + DECL_ATTRIBUTES (omp_alt_alloc)); + omp_alt_alloc = build_call_expr (omp_alt_alloc, 3, align, sz, alloc); + succ_add_expr = fold_build2_loc (input_location, MODIFY_EXPR, + void_type_node, + gfc_conv_descriptor_version (se->expr), + build_int_cst (integer_type_node, 1)); + } + /* The allocatable variant takes the old pointer as first argument. */ if (allocatable) gfc_allocate_allocatable (&elseblock, pointer, size, token, status, errmsg, errlen, label_finish, expr, - coref != NULL ? coref->u.ar.as->corank : 0); + coref != NULL ? coref->u.ar.as->corank : 0, + omp_cond, omp_alt_alloc, succ_add_expr); else if (non_ulimate_coarray_ptr_comp && token) /* The token is set only for GFC_FCOARRAY_LIB mode. */ gfc_allocate_using_caf_lib (&elseblock, pointer, size, token, status, errmsg, errlen, GFC_CAF_COARRAY_ALLOC_ALLOCATE_ONLY); else - gfc_allocate_using_malloc (&elseblock, pointer, size, status); + gfc_allocate_using_malloc (&elseblock, pointer, size, status, + omp_cond, omp_alt_alloc, succ_add_expr); if (dimension) { @@ -9603,11 +9671,6 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, else if (attr->dimension && !attr->proc_pointer) caf_token = gfc_conv_descriptor_token (comp); } - if (attr->dimension && !attr->codimension && !attr->proc_pointer) - /* When this is an array but not in conjunction with a coarray - then add the data-ref. For coarray'ed arrays the data-ref - is added by deallocate_with_status. */ - comp = gfc_conv_descriptor_data_get (comp); tmp = gfc_deallocate_with_status (comp, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, true, @@ -10292,29 +10355,50 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest, gfc_add_expr_to_block (&fnblock, tmp); } - if (c->attr.pdt_array) + if (c->attr.pdt_array || c->attr.pdt_string) { - tmp = gfc_conv_descriptor_data_get (comp); + tmp = comp; + if (c->attr.pdt_array) + tmp = gfc_conv_descriptor_data_get (comp); null_cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp, build_int_cst (TREE_TYPE (tmp), 0)); - tmp = gfc_call_free (tmp); - tmp = build3_v (COND_EXPR, null_cond, tmp, - build_empty_stmt (input_location)); - gfc_add_expr_to_block (&fnblock, tmp); - gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node); - } - else if (c->attr.pdt_string) - { - null_cond = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, comp, - build_int_cst (TREE_TYPE (comp), 0)); - tmp = gfc_call_free (comp); + if (flag_openmp_allocators) + { + tree cd, t; + if (c->attr.pdt_array) + cd = fold_build2_loc (input_location, EQ_EXPR, + boolean_type_node, + gfc_conv_descriptor_version (comp), + build_int_cst (integer_type_node, 1)); + else + cd = gfc_omp_call_is_alloc (tmp); + t = builtin_decl_explicit (BUILT_IN_GOMP_FREE); + t = build_call_expr_loc (input_location, t, 1, tmp); + + stmtblock_t tblock; + gfc_init_block (&tblock); + gfc_add_expr_to_block (&tblock, t); + if (c->attr.pdt_array) + gfc_add_modify (&tblock, gfc_conv_descriptor_version (comp), + build_zero_cst (integer_type_node)); + tmp = build3_loc (input_location, COND_EXPR, void_type_node, + cd, gfc_finish_block (&tblock), + gfc_call_free (tmp)); + } + else + tmp = gfc_call_free (tmp); tmp = build3_v (COND_EXPR, null_cond, tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&fnblock, tmp); - tmp = fold_convert (TREE_TYPE (comp), null_pointer_node); - gfc_add_modify (&fnblock, comp, tmp); + + if (c->attr.pdt_array) + gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node); + else + { + tmp = fold_convert (TREE_TYPE (comp), null_pointer_node); + gfc_add_modify (&fnblock, comp, tmp); + } } break; @@ -11248,8 +11332,22 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop, builtin_decl_explicit (BUILT_IN_REALLOC), 2, fold_convert (pvoid_type_node, array1), size2); - gfc_conv_descriptor_data_set (&realloc_block, - desc, tmp); + if (flag_openmp_allocators) + { + tree cond, omp_tmp; + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + gfc_conv_descriptor_version (desc), + build_int_cst (integer_type_node, 1)); + omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_REALLOC); + omp_tmp = build_call_expr_loc (input_location, omp_tmp, 4, + fold_convert (pvoid_type_node, array1), size2, + build_zero_cst (ptr_type_node), + build_zero_cst (ptr_type_node)); + tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond, + omp_tmp, tmp); + } + + gfc_conv_descriptor_data_set (&realloc_block, desc, tmp); } else { diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 5408755138e..6cdcc9a3e75 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -21,7 +21,8 @@ along with GCC; see the file COPYING3. If not see /* Generate code to initialize and allocate an array. Statements are added to se, which should contain an expression for the array descriptor. */ bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, tree, - tree, tree *, gfc_expr *, tree, bool); + tree, tree *, gfc_expr *, tree, bool, + gfc_omp_namelist *); /* Allow the bounds of a loop to be set from a callee's array spec. */ void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *, @@ -177,6 +178,7 @@ tree gfc_conv_descriptor_span_get (tree); tree gfc_conv_descriptor_dtype (tree); tree gfc_conv_descriptor_rank (tree); tree gfc_conv_descriptor_elem_len (tree); +tree gfc_conv_descriptor_version (tree); tree gfc_conv_descriptor_attribute (tree); tree gfc_conv_descriptor_type (tree); tree gfc_get_descriptor_dimension (tree); diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc index b86cfec7d49..cf848406a05 100644 --- a/gcc/fortran/trans-decl.cc +++ b/gcc/fortran/trans-decl.cc @@ -4350,7 +4350,7 @@ gfc_init_default_dt (gfc_symbol * sym, stmtblock_t * block, bool dealloc) /* Initialize INTENT(OUT) derived type dummies. As well as giving - them their default initializer, if they do not have allocatable + them their default initializer, if they have allocatable components, they have their allocatable components deallocated. */ static void diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index ea087294249..b2463a28748 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -7173,8 +7173,6 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, if (TREE_TYPE(tmp) != pvoid_type_node) tmp = build_fold_indirect_ref_loc (input_location, parmse.expr); - if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) - tmp = gfc_conv_descriptor_data_get (tmp); tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, true, e, @@ -11731,8 +11729,30 @@ alloc_scalar_allocatable_for_assignment (stmtblock_t *block, builtin_decl_explicit (BUILT_IN_REALLOC), 2, fold_convert (pvoid_type_node, lse.expr), size_in_bytes); + tree omp_cond = NULL_TREE; + if (flag_openmp_allocators) + { + tree omp_tmp; + omp_cond = gfc_omp_call_is_alloc (lse.expr); + omp_cond = gfc_evaluate_now (omp_cond, block); + + omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_REALLOC); + omp_tmp = build_call_expr_loc (input_location, omp_tmp, 4, + fold_convert (pvoid_type_node, + lse.expr), size_in_bytes, + build_zero_cst (ptr_type_node), + build_zero_cst (ptr_type_node)); + tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), + omp_cond, omp_tmp, tmp); + } tmp = fold_convert (TREE_TYPE (lse.expr), tmp); gfc_add_modify (block, lse.expr, tmp); + if (omp_cond) + gfc_add_expr_to_block (block, + build3_loc (input_location, COND_EXPR, + void_type_node, omp_cond, + gfc_omp_call_add_alloc (lse.expr), + build_empty_stmt (input_location))); tmp = build1_v (LABEL_EXPR, jump_label2); gfc_add_expr_to_block (block, tmp); diff --git a/gcc/fortran/trans-intrinsic.cc b/gcc/fortran/trans-intrinsic.cc index 289309190a5..05e111c0fcc 100644 --- a/gcc/fortran/trans-intrinsic.cc +++ b/gcc/fortran/trans-intrinsic.cc @@ -12819,9 +12819,8 @@ conv_intrinsic_move_alloc (gfc_code *code) gfc_add_expr_to_block (&block, tmp); } - tmp = gfc_conv_descriptor_data_get (to_se.expr); - tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE, - NULL_TREE, true, to_expr, + tmp = gfc_deallocate_with_status (to_se.expr, NULL_TREE, NULL_TREE, + NULL_TREE, NULL_TREE, true, to_expr, GFC_CAF_COARRAY_NOCOARRAY); gfc_add_expr_to_block (&block, tmp); } diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc index 82bbc41b388..9e166c94f8e 100644 --- a/gcc/fortran/trans-openmp.cc +++ b/gcc/fortran/trans-openmp.cc @@ -4842,6 +4842,30 @@ static tree gfc_trans_omp_sections (gfc_code *, gfc_omp_clauses *); static tree gfc_trans_omp_workshare (gfc_code *, gfc_omp_clauses *); static tree +gfc_trans_omp_allocators (gfc_code *code) +{ + static bool warned = false; + gfc_omp_namelist *omp_allocate + = code->ext.omp_clauses->lists[OMP_LIST_ALLOCATE]; + if (!flag_openmp_allocators && !warned) + { + omp_allocate = NULL; + gfc_error ("%<!$OMP %s%> at %L requires %<-fopenmp-allocators%>", + code->op == EXEC_OMP_ALLOCATE ? "ALLOCATE" : "ALLOCATORS", + &code->loc); + warning (0, "All files that might deallocate such a variable must be " + "compiled with %<-fopenmp-allocators%>"); + inform (UNKNOWN_LOCATION, + "This includes explicit DEALLOCATE, reallocation on intrinsic " + "assignment, INTENT(OUT) for allocatable dummy arguments, and " + "reallocation of allocatable components allocated with an " + "OpenMP allocator"); + warned = true; + } + return gfc_trans_allocate (code->block->next, omp_allocate); +} + +static tree gfc_trans_omp_assume (gfc_code *code) { stmtblock_t block; @@ -7992,9 +8016,7 @@ gfc_trans_omp_directive (gfc_code *code) { case EXEC_OMP_ALLOCATE: case EXEC_OMP_ALLOCATORS: - sorry ("%<!$OMP %s%> not yet supported", - code->op == EXEC_OMP_ALLOCATE ? "ALLOCATE" : "ALLOCATORS"); - return NULL_TREE; + return gfc_trans_omp_allocators (code); case EXEC_OMP_ASSUME: return gfc_trans_omp_assume (code); case EXEC_OMP_ATOMIC: @@ -8329,3 +8351,36 @@ gfc_trans_omp_declare_variant (gfc_namespace *ns) } } } + +/* Add ptr for tracking as being allocated by GOMP_alloc. */ + +tree +gfc_omp_call_add_alloc (tree ptr) +{ + static tree fn = NULL_TREE; + if (fn == NULL_TREE) + { + fn = build_function_type_list (void_type_node, ptr_type_node, NULL_TREE); + fn = build_fn_decl ("GOMP_add_alloc", fn); +/* FIXME: attributes. */ + } + return build_call_expr_loc (input_location, fn, 1, ptr); +} + +/* Generated function returns true when it was tracked via GOMP_add_alloc and + removes it from the tracking. As called just before GOMP_free or omp_realloc + the pointer is or might become invalid, thus, it is always removed. */ + +tree +gfc_omp_call_is_alloc (tree ptr) +{ + static tree fn = NULL_TREE; + if (fn == NULL_TREE) + { + fn = build_function_type_list (boolean_type_node, ptr_type_node, + NULL_TREE); + fn = build_fn_decl ("GOMP_is_alloc", fn); +/* FIXME: attributes. */ + } + return build_call_expr_loc (input_location, fn, 1, ptr); +} diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index 50b71e67234..5530e893a62 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -6228,7 +6228,7 @@ allocate_get_initializer (gfc_code * code, gfc_expr * expr) /* Translate the ALLOCATE statement. */ tree -gfc_trans_allocate (gfc_code * code) +gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate) { gfc_alloc *al; gfc_expr *expr, *e3rhs = NULL, *init_expr; @@ -6790,11 +6790,38 @@ gfc_trans_allocate (gfc_code * code) else tmp = expr3_esize; + gfc_omp_namelist *omp_alloc_item = NULL; + if (omp_allocate) + { + gfc_omp_namelist *n = NULL; + gfc_omp_namelist *n_null = NULL; + for (n = omp_allocate; n; n = n->next) + { + if (n->sym == NULL) + { + n_null = n; + continue; + } + if (expr->expr_type == EXPR_VARIABLE + && expr->symtree->n.sym == n->sym) + { + gfc_ref *ref; + for (ref = expr->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + break; + if (ref == NULL) + break; + } + } + omp_alloc_item = n ? n : n_null; + + } + if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, label_finish, tmp, &nelems, e3rhs ? e3rhs : code->expr3, e3_is == E3_DESC ? expr3 : NULL_TREE, - e3_has_nodescriptor)) + e3_has_nodescriptor, omp_alloc_item)) { /* A scalar or derived type. First compute the size to allocate. @@ -6874,10 +6901,59 @@ gfc_trans_allocate (gfc_code * code) /* Handle size computation of the type declared to alloc. */ memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr))); + bool use_coarray_alloc + = (flag_coarray == GFC_FCOARRAY_LIB + && (caf_attr = gfc_caf_attr (expr, true, &caf_refs_comp)) + .codimension); + tree omp_cond = NULL_TREE; + tree omp_alt_alloc = NULL_TREE; + tree succ_add_expr = NULL_TREE; + if (!use_coarray_alloc && omp_alloc_item) + { + tree align, alloc, sz; + gfc_se se2; + + omp_cond = boolean_true_node; + if (omp_alloc_item->u2.allocator) + { + gfc_init_se (&se2, NULL); + gfc_conv_expr (&se2, omp_alloc_item->u2.allocator); + gfc_add_block_to_block (&se.pre, &se2.pre); + alloc = gfc_evaluate_now (se2.expr, &se.pre); + gfc_add_block_to_block (&se.pre, &se2.post); + } + else + alloc = build_zero_cst (ptr_type_node); + tmp = TREE_TYPE (TREE_TYPE (se.expr)); + if (tmp == void_type_node) + tmp = gfc_typenode_for_spec (&expr->ts, 0); + if (omp_alloc_item->u.align) + { + gfc_init_se (&se2, NULL); + gfc_conv_expr (&se2, omp_alloc_item->u.align); + gcc_assert (CONSTANT_CLASS_P (se2.expr) + && se2.pre.head == NULL + && se2.post.head == NULL); + align = build_int_cst (size_type_node, + MAX (tree_to_uhwi (se2.expr), + TYPE_ALIGN_UNIT (tmp))); + } + else + align = build_int_cst (size_type_node, TYPE_ALIGN_UNIT (tmp)); + sz = fold_build2_loc (input_location, MAX_EXPR, size_type_node, + fold_convert (size_type_node, memsz), + build_int_cst (size_type_node, 1)); + omp_alt_alloc = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC); + DECL_ATTRIBUTES (omp_alt_alloc) + = tree_cons (get_identifier ("omp allocator"), + build_tree_list (NULL_TREE, alloc), + DECL_ATTRIBUTES (omp_alt_alloc)); + omp_alt_alloc = build_call_expr (omp_alt_alloc, 3, align, sz, alloc); + succ_add_expr = gfc_omp_call_add_alloc (se.expr); + } + /* Store the caf-attributes for latter use. */ - if (flag_coarray == GFC_FCOARRAY_LIB - && (caf_attr = gfc_caf_attr (expr, true, &caf_refs_comp)) - .codimension) + if (use_coarray_alloc) { /* Scalar allocatable components in coarray'ed derived types make it here and are treated now. */ @@ -6904,9 +6980,11 @@ gfc_trans_allocate (gfc_code * code) else if (gfc_expr_attr (expr).allocatable) gfc_allocate_allocatable (&se.pre, se.expr, memsz, NULL_TREE, stat, errmsg, errlen, - label_finish, expr, 0); + label_finish, expr, 0, + omp_cond, omp_alt_alloc, succ_add_expr); else - gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat); + gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat, + omp_cond, omp_alt_alloc, succ_add_expr); } else { diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h index 101a0540ef4..270ebcf9915 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -64,7 +64,7 @@ tree gfc_trans_change_team (gfc_code *); tree gfc_trans_end_team (gfc_code *); tree gfc_trans_sync_team (gfc_code *); tree gfc_trans_where (gfc_code *); -tree gfc_trans_allocate (gfc_code *); +tree gfc_trans_allocate (gfc_code *, gfc_omp_namelist *); tree gfc_trans_deallocate (gfc_code *); /* trans-openmp.cc */ diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc index 5b11ffc3cc9..11a583ca92c 100644 --- a/gcc/fortran/trans-types.cc +++ b/gcc/fortran/trans-types.cc @@ -1601,6 +1601,10 @@ gfc_get_dtype_rank_type (int rank, tree etype) GFC_DTYPE_ELEM_LEN); CONSTRUCTOR_APPEND_ELT (v, field, fold_convert (TREE_TYPE (field), size)); + field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node), + GFC_DTYPE_VERSION); + CONSTRUCTOR_APPEND_ELT (v, field, + build_zero_cst (TREE_TYPE (field))); field = gfc_advance_chain (TYPE_FIELDS (dtype_type_node), GFC_DTYPE_RANK); diff --git a/gcc/fortran/trans.cc b/gcc/fortran/trans.cc index e2e1b694012..961b0b5a573 100644 --- a/gcc/fortran/trans.cc +++ b/gcc/fortran/trans.cc @@ -796,7 +796,10 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size) if (stat requested) stat = 0; + // if cond == NULL_NULL: newmem = malloc (MAX (size, 1)); + // otherwise: + newmem = <cond> ? <alt_alloc> : malloc (MAX (size, 1)) if (newmem == NULL) { if (stat) @@ -808,7 +811,8 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size) } */ void gfc_allocate_using_malloc (stmtblock_t * block, tree pointer, - tree size, tree status) + tree size, tree status, tree cond, tree alt_alloc, + tree extra_success_expr) { tree tmp, error_cond; stmtblock_t on_error; @@ -822,13 +826,18 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree pointer, /* The allocation itself. */ size = fold_convert (size_type_node, size); - gfc_add_modify (block, pointer, - fold_convert (TREE_TYPE (pointer), - build_call_expr_loc (input_location, - builtin_decl_explicit (BUILT_IN_MALLOC), 1, - fold_build2_loc (input_location, - MAX_EXPR, size_type_node, size, - build_int_cst (size_type_node, 1))))); + tmp = fold_build2_loc (input_location, MAX_EXPR, size_type_node, + size, build_int_cst (size_type_node, 1)); + + tmp = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_MALLOC), 1, tmp); + if (cond == boolean_true_node) + tmp = alt_alloc; + else if (cond) + tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond, + alt_alloc, tmp); + + gfc_add_modify (block, pointer, fold_convert (TREE_TYPE (pointer), tmp)); /* What to do in case of error. */ gfc_start_block (&on_error); @@ -852,7 +861,9 @@ gfc_allocate_using_malloc (stmtblock_t * block, tree pointer, tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, gfc_unlikely (error_cond, PRED_FORTRAN_FAIL_ALLOC), gfc_finish_block (&on_error), - build_empty_stmt (input_location)); + extra_success_expr + ? extra_success_expr + : build_empty_stmt (input_location)); gfc_add_expr_to_block (block, tmp); } @@ -938,7 +949,8 @@ gfc_allocate_using_caf_lib (stmtblock_t * block, tree pointer, tree size, void gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree token, tree status, tree errmsg, tree errlen, - tree label_finish, gfc_expr* expr, int corank) + tree label_finish, gfc_expr* expr, int corank, + tree cond, tree alt_alloc, tree extra_success_expr) { stmtblock_t alloc_block; tree tmp, null_mem, alloc, error; @@ -963,7 +975,7 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, if (flag_coarray == GFC_FCOARRAY_LIB && (corank > 0 || caf_attr.codimension)) { - tree cond, sub_caf_tree; + tree cond2, sub_caf_tree; gfc_se se; bool compute_special_caf_types_size = false; @@ -1027,16 +1039,17 @@ gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, { TREE_USED (label_finish) = 1; tmp = build1_v (GOTO_EXPR, label_finish); - cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, - status, build_zero_cst (TREE_TYPE (status))); + cond2 = fold_build2_loc (input_location, NE_EXPR, logical_type_node, + status, build_zero_cst (TREE_TYPE (status))); tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC), + gfc_unlikely (cond2, PRED_FORTRAN_FAIL_ALLOC), tmp, build_empty_stmt (input_location)); gfc_add_expr_to_block (&alloc_block, tmp); } } else - gfc_allocate_using_malloc (&alloc_block, mem, size, status); + gfc_allocate_using_malloc (&alloc_block, mem, size, status, + cond, alt_alloc, extra_success_expr); alloc = gfc_finish_block (&alloc_block); @@ -1781,6 +1794,7 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, tree cond, tmp, error; tree status_type = NULL_TREE; tree token = NULL_TREE; + tree descr = NULL_TREE; gfc_coarray_deregtype caf_dereg_type = GFC_CAF_COARRAY_DEREGISTER; if (coarray_dealloc_mode >= GFC_CAF_COARRAY_ANALYZE) @@ -1788,7 +1802,11 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, if (flag_coarray == GFC_FCOARRAY_LIB) { if (caf_token) - token = caf_token; + { + token = caf_token; + if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer))) + pointer = gfc_conv_descriptor_data_get (pointer); + } else { tree caf_type, caf_decl = pointer; @@ -1824,7 +1842,10 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, pointer = gfc_conv_descriptor_data_get (pointer); } else if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (pointer))) - pointer = gfc_conv_descriptor_data_get (pointer); + { + descr = pointer; + pointer = gfc_conv_descriptor_data_get (pointer); + } cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, pointer, build_int_cst (TREE_TYPE (pointer), 0)); @@ -1876,9 +1897,27 @@ gfc_deallocate_with_status (tree pointer, tree status, tree errmsg, tmp = build_call_expr_loc (input_location, builtin_decl_explicit (BUILT_IN_FREE), 1, fold_convert (pvoid_type_node, pointer)); + if (flag_openmp_allocators && coarray_dealloc_mode < GFC_CAF_COARRAY_ANALYZE) + { + tree cond, omp_tmp; + if (descr) + cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, + gfc_conv_descriptor_version (descr), + build_int_cst (integer_type_node, 1)); + else + cond = gfc_omp_call_is_alloc (pointer); + omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_FREE); + omp_tmp = build_call_expr_loc (input_location, omp_tmp, 2, pointer, + build_zero_cst (ptr_type_node)); + tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond, + omp_tmp, tmp); + } gfc_add_expr_to_block (&non_null, tmp); gfc_add_modify (&non_null, pointer, build_int_cst (TREE_TYPE (pointer), 0)); + if (flag_openmp_allocators && descr) + gfc_add_modify (&non_null, gfc_conv_descriptor_version (descr), + build_zero_cst (integer_type_node)); if (status != NULL_TREE && !integer_zerop (status)) { @@ -2050,6 +2089,16 @@ gfc_deallocate_scalar_with_status (tree pointer, tree status, tree label_finish, tmp = build_call_expr_loc (input_location, builtin_decl_explicit (BUILT_IN_FREE), 1, fold_convert (pvoid_type_node, pointer)); + if (flag_openmp_allocators) + { + tree cond, omp_tmp; + cond = gfc_omp_call_is_alloc (pointer); + omp_tmp = builtin_decl_explicit (BUILT_IN_GOMP_FREE); + omp_tmp = build_call_expr_loc (input_location, omp_tmp, 2, pointer, + build_zero_cst (ptr_type_node)); + tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), cond, + omp_tmp, tmp); + } gfc_add_expr_to_block (&non_null, tmp); if (status != NULL_TREE && !integer_zerop (status)) @@ -2483,7 +2532,7 @@ trans_code (gfc_code * code, tree cond) break; case EXEC_ALLOCATE: - res = gfc_trans_allocate (code); + res = gfc_trans_allocate (code, NULL); break; case EXEC_DEALLOCATE: diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 109d7647235..728d4f8f43f 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -764,10 +764,14 @@ void gfc_allocate_using_caf_lib (stmtblock_t *, tree, tree, tree, tree, tree, /* Allocate memory for allocatable variables, with optional status variable. */ void gfc_allocate_allocatable (stmtblock_t*, tree, tree, tree, tree, - tree, tree, tree, gfc_expr*, int); + tree, tree, tree, gfc_expr*, int, + tree = NULL_TREE, tree = NULL_TREE, + tree = NULL_TREE); /* Allocate memory, with optional status variable. */ -void gfc_allocate_using_malloc (stmtblock_t *, tree, tree, tree); +void gfc_allocate_using_malloc (stmtblock_t *, tree, tree, tree, + tree = NULL_TREE, tree = NULL_TREE, + tree = NULL_TREE); /* Generate code to deallocate an array. */ tree gfc_deallocate_with_status (tree, tree, tree, tree, tree, bool, @@ -817,6 +821,8 @@ struct array_descr_info; bool gfc_get_array_descr_info (const_tree, struct array_descr_info *); /* In trans-openmp.cc */ +tree gfc_omp_call_add_alloc (tree); +tree gfc_omp_call_is_alloc (tree); bool gfc_omp_is_allocatable_or_ptr (const_tree); tree gfc_omp_check_optional_argument (tree, bool); tree gfc_omp_array_data (tree, bool); diff --git a/gcc/fortran/types.def b/gcc/fortran/types.def index 7a465c89c5f..5462381cdd4 100644 --- a/gcc/fortran/types.def +++ b/gcc/fortran/types.def @@ -155,6 +155,8 @@ DEF_FUNCTION_TYPE_3 (BT_FN_UINT_UINT_PTR_PTR, BT_UINT, BT_UINT, BT_PTR, BT_PTR) DEF_FUNCTION_TYPE_3 (BT_FN_PTR_SIZE_SIZE_PTRMODE, BT_PTR, BT_SIZE, BT_SIZE, BT_PTRMODE) +DEF_FUNCTION_TYPE_4 (BT_FN_PTR_PTR_SIZE_PTRMODE_PTRMODE, + BT_PTR, BT_PTR, BT_SIZE, BT_PTRMODE, BT_PTRMODE) DEF_FUNCTION_TYPE_4 (BT_FN_VOID_OMPFN_PTR_UINT_UINT, BT_VOID, BT_PTR_FN_VOID_PTR, BT_PTR, BT_UINT, BT_UINT) DEF_FUNCTION_TYPE_4 (BT_FN_UINT_OMPFN_PTR_UINT_UINT, diff --git a/gcc/gimple-ssa-warn-access.cc b/gcc/gimple-ssa-warn-access.cc index da2e3fe3a0d..1646bd1be14 100644 --- a/gcc/gimple-ssa-warn-access.cc +++ b/gcc/gimple-ssa-warn-access.cc @@ -1574,6 +1574,7 @@ fndecl_alloc_p (tree fndecl, bool all_alloc) case BUILT_IN_ALIGNED_ALLOC: case BUILT_IN_CALLOC: case BUILT_IN_GOMP_ALLOC: + case BUILT_IN_GOMP_REALLOC: case BUILT_IN_MALLOC: case BUILT_IN_REALLOC: case BUILT_IN_STRDUP: @@ -1801,9 +1802,20 @@ matching_alloc_calls_p (tree alloc_decl, tree dealloc_decl) case BUILT_IN_ALLOCA_WITH_ALIGN: return false; + case BUILT_IN_GOMP_ALLOC: + case BUILT_IN_GOMP_REALLOC: + if (DECL_IS_OPERATOR_DELETE_P (dealloc_decl)) + return false; + + if (fndecl_built_in_p (dealloc_decl, BUILT_IN_GOMP_FREE, + BUILT_IN_GOMP_REALLOC)) + return true; + + alloc_dealloc_kind = alloc_kind_t::builtin; + break; + case BUILT_IN_ALIGNED_ALLOC: case BUILT_IN_CALLOC: - case BUILT_IN_GOMP_ALLOC: case BUILT_IN_MALLOC: case BUILT_IN_REALLOC: case BUILT_IN_STRDUP: @@ -1829,7 +1841,8 @@ matching_alloc_calls_p (tree alloc_decl, tree dealloc_decl) if (fndecl_built_in_p (dealloc_decl, BUILT_IN_NORMAL)) { built_in_function dealloc_code = DECL_FUNCTION_CODE (dealloc_decl); - if (dealloc_code == BUILT_IN_REALLOC) + if (dealloc_code == BUILT_IN_REALLOC + || dealloc_code == BUILT_IN_GOMP_REALLOC) realloc_kind = alloc_kind_t::builtin; for (tree amats = DECL_ATTRIBUTES (alloc_decl); @@ -1882,6 +1895,7 @@ matching_alloc_calls_p (tree alloc_decl, tree dealloc_decl) case BUILT_IN_ALIGNED_ALLOC: case BUILT_IN_CALLOC: case BUILT_IN_GOMP_ALLOC: + case BUILT_IN_GOMP_REALLOC: case BUILT_IN_MALLOC: case BUILT_IN_REALLOC: case BUILT_IN_STRDUP: diff --git a/gcc/gimple.cc b/gcc/gimple.cc index 7924d900b35..67f3fb2dabf 100644 --- a/gcc/gimple.cc +++ b/gcc/gimple.cc @@ -2988,6 +2988,8 @@ nonfreeing_call_p (gimple *call) case BUILT_IN_TM_FREE: case BUILT_IN_REALLOC: case BUILT_IN_STACK_RESTORE: + case BUILT_IN_GOMP_FREE: + case BUILT_IN_GOMP_REALLOC: return false; default: return true; diff --git a/gcc/omp-builtins.def b/gcc/omp-builtins.def index ed78d49d205..7b6b1dca3e3 100644 --- a/gcc/omp-builtins.def +++ b/gcc/omp-builtins.def @@ -467,6 +467,9 @@ DEF_GOMP_BUILTIN (BUILT_IN_GOMP_WORKSHARE_TASK_REDUCTION_UNREGISTER, DEF_GOMP_BUILTIN (BUILT_IN_GOMP_ALLOC, "GOMP_alloc", BT_FN_PTR_SIZE_SIZE_PTRMODE, ATTR_ALLOC_WARN_UNUSED_RESULT_SIZE_2_NOTHROW_LIST) +DEF_GOMP_BUILTIN (BUILT_IN_GOMP_REALLOC, + "omp_realloc", BT_FN_PTR_PTR_SIZE_PTRMODE_PTRMODE, + ATTR_ALLOC_WARN_UNUSED_RESULT_SIZE_2_NOTHROW_LEAF_LIST) DEF_GOMP_BUILTIN (BUILT_IN_GOMP_FREE, "GOMP_free", BT_FN_VOID_PTR_PTRMODE, ATTR_NOTHROW_LEAF_LIST) DEF_GOMP_BUILTIN (BUILT_IN_GOMP_WARNING, "GOMP_warning", diff --git a/gcc/predict.cc b/gcc/predict.cc index 396746cbfd1..2e9b7dd07a7 100644 --- a/gcc/predict.cc +++ b/gcc/predict.cc @@ -2566,6 +2566,7 @@ expr_expected_value_1 (tree type, tree op0, enum tree_code code, *predictor = PRED_COMPARE_AND_SWAP; return boolean_true_node; case BUILT_IN_REALLOC: + case BUILT_IN_GOMP_REALLOC: if (predictor) *predictor = PRED_MALLOC_NONNULL; /* FIXME: This is wrong and we need to convert the logic diff --git a/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 b/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 index 04faa433435..0825efc7a2f 100644 --- a/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 +++ b/gcc/testsuite/gfortran.dg/bind_c_array_params_2.f90 @@ -25,7 +25,7 @@ end ! { dg-final { scan-tree-dump "parm...span = 4;" "original" } } -! { dg-final { scan-tree-dump "parm...dtype = {.elem_len=4, .rank=2, .type=1};" "original" } } +! { dg-final { scan-tree-dump "parm...dtype = {.elem_len=4, .version=0, .rank=2, .type=1};" "original" } } ! { dg-final { scan-tree-dump "parm...dim\\\[0\\\].lbound = 1;" "original" } } ! { dg-final { scan-tree-dump "parm...dim\\\[0\\\].ubound = 4;" "original" } } ! { dg-final { scan-tree-dump "parm...dim\\\[0\\\].stride = 1;" "original" } } diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-14.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-14.f90 index 8ff9c252e49..4fed19249a3 100644 --- a/gcc/testsuite/gfortran.dg/gomp/allocate-14.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-14.f90 @@ -93,3 +93,44 @@ subroutine c_and_func_ptrs !$omp allocate(cfunptr) ! OK? A normal derived-type var? !$omp allocate(p) ! { dg-error "Argument 'p' at .1. to declarative !.OMP ALLOCATE directive must be a variable" } end + + +subroutine coarray_2 + use m + implicit none + integer :: x + integer, allocatable :: a, b, c[:], d + x = 5 ! executable stmt + !$omp allocate(a,b) align(16) + !$omp allocate ! { dg-error "Unexpected coarray 'c' in 'allocate' at .1., implicitly listed in '!.OMP ALLOCATE' at .2." } + !$omp allocate(d) align(32) + allocate(a,b,c[*],d) ! { dg-error "Unexpected coarray 'c' in 'allocate' at .1., implicitly listed in '!.OMP ALLOCATE' at .2." } +end + + +subroutine coarray_3 + use m + implicit none + integer :: x + integer, allocatable :: a, b, c[:], d + x = 5 ! executable stmt + !$omp allocators allocate(align(16): a,b) allocate(align(32) : d) + allocate(a,b,c[*],d) ! OK - Fortran allocator used for 'C' +end + + +subroutine unclear + use m + implicit none + integer :: x + integer, allocatable :: a, b, c[:], d + + ! OpenMP is unclear which allocator is used for 'C' - the fortran one or the OpenMP one. + ! GCC therefore rejects it. + + x = 5 ! executable stmt + + !$omp allocate(a,b) align(16) + !$omp allocate(d) align(32) + allocate(a,b,c[*],d) ! { dg-error "'c' listed in 'allocate' statement at .1. but it is neither explicitly in listed in the '!.OMP ALLOCATE' directive nor exists a directive without argument list" } +end diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-16.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-16.f90 new file mode 100644 index 00000000000..6c203e02d57 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-16.f90 @@ -0,0 +1,10 @@ +integer, pointer :: ptr + +!$omp flush +!$omp allocate(ptr) +allocate(ptr) +end + +! { dg-error "'!.OMP ALLOCATE' at .1. requires '-fopenmp-allocators'" "" { target *-*-* } 4 } +! { dg-warning "All files that might deallocate such a variable must be compiled with '-fopenmp-allocators'" "" { target *-*-* } 4 } +! { dg-note "This includes explicit DEALLOCATE, reallocation on intrinsic assignment, INTENT\\(OUT\\) for allocatable dummy arguments, and reallocation of allocatable components allocated with an OpenMP allocator" "" { target *-*-* } 0 } diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-5.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-5.f90 index bf9c781dcc5..28369ae876b 100644 --- a/gcc/testsuite/gfortran.dg/gomp/allocate-5.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-5.f90 @@ -1,3 +1,4 @@ +! { dg-additional-options "-fopenmp-allocators" } module my_omp_lib use iso_c_binding, only: c_intptr_t !use omp_lib @@ -45,15 +46,15 @@ subroutine two(c,x2,y2) class(t), pointer :: y2(:) !$omp flush ! some executable statement - !$omp allocate(a) ! { dg-message "not yet supported" } - allocate(a,b(4),c(3,4)) - deallocate(a,b,c) + !$omp allocate(a) + allocate(a) + deallocate(a) - !$omp allocate(x1,y1,x2,y2) ! { dg-message "not yet supported" } + !$omp allocate(x1,y1,x2,y2) allocate(x1,y1,x2(5),y2(5)) deallocate(x1,y1,x2,y2) - !$omp allocate(b,a) align ( 128 ) ! { dg-message "not yet supported" } + !$omp allocate(b,a) align ( 128 ) !$omp allocate align ( 64 ) allocate(a,b(4),c(3,4)) deallocate(a,b,c) @@ -66,7 +67,7 @@ subroutine three(c) integer, allocatable :: a, b(:), c(:,:) call foo() ! executable stmt - !$omp allocate allocator( omp_large_cap_mem_alloc ) , align(64) ! { dg-message "not yet supported" } + !$omp allocate allocator( omp_large_cap_mem_alloc ) , align(64) !$omp allocate(b) allocator( omp_high_bw_mem_alloc ) !$omp allocate(c) allocator( omp_high_bw_mem_alloc ) allocate(a,b(4),c(3,4)) @@ -74,7 +75,7 @@ subroutine three(c) block q = 5 ! executable stmt - !$omp allocate(a) align(64) ! { dg-message "not yet supported" } + !$omp allocate(a) align(64) !$omp allocate(b) allocator( omp_high_bw_mem_alloc ), align(32) !$omp allocate(c) allocator( omp_thread_mem_alloc ) allocate(a,b(4),c(3,4)) @@ -84,7 +85,7 @@ subroutine three(c) contains subroutine inner call foo() ! executable stmt - !$omp allocate(a) align(64) ! { dg-message "not yet supported" } + !$omp allocate(a) align(64) !$omp allocate(b) allocator( omp_high_bw_mem_alloc ), align(32) !$omp allocate(c) allocator( omp_thread_mem_alloc ) allocate(a,b(4),c(3,4)) diff --git a/gcc/testsuite/gfortran.dg/gomp/allocators-3.f90 b/gcc/testsuite/gfortran.dg/gomp/allocators-3.f90 new file mode 100644 index 00000000000..d0e31ee8727 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/allocators-3.f90 @@ -0,0 +1,36 @@ +subroutine f + integer, allocatable :: A1, A2, B(:), C + !$omp declare target + + !$omp allocators ! OK + allocate(A1) + + !$omp allocators allocate(align(8) : a2) ! { dg-error "ALLOCATORS directive at .1. inside a target region must specify an ALLOCATOR modifier for 'a2'" } + allocate(A2) + + !$omp allocate ! { dg-error "ALLOCATE directive at .1. inside a target region must specify an ALLOCATOR clause" } + allocate(B(5)) + + !$omp allocate(c) ! { dg-error "ALLOCATE directive at .1. inside a target region must specify an ALLOCATOR clause for 'c'" } + allocate(C) +end + +subroutine g + integer, allocatable :: A1, A2, B(:), C + + !$omp target + !$omp single + !$omp allocators ! OK + allocate(A1) + + !$omp allocators allocate(align(8) : a2) ! { dg-error "ALLOCATORS directive at .1. inside a target region must specify an ALLOCATOR modifier for 'a2'" } + allocate(A2) + + !$omp allocate ! { dg-error "ALLOCATE directive at .1. inside a target region must specify an ALLOCATOR clause" } + allocate(B(5)) + + !$omp allocate(c) ! { dg-error "ALLOCATE directive at .1. inside a target region must specify an ALLOCATOR clause for 'c'" } + allocate(C) + !$omp end single + !$omp end target +end diff --git a/gcc/testsuite/gfortran.dg/gomp/allocators-4.f90 b/gcc/testsuite/gfortran.dg/gomp/allocators-4.f90 new file mode 100644 index 00000000000..55ae48d61f2 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/allocators-4.f90 @@ -0,0 +1,9 @@ +integer, pointer :: ptr + +!$omp allocators allocate(ptr) +allocate(ptr) +end + +! { dg-error "'!.OMP ALLOCATORS' at .1. requires '-fopenmp-allocators'" "" { target *-*-* } 3 } +! { dg-warning "All files that might deallocate such a variable must be compiled with '-fopenmp-allocators'" "" { target *-*-* } 3 } +! { dg-note "This includes explicit DEALLOCATE, reallocation on intrinsic assignment, INTENT\\(OUT\\) for allocatable dummy arguments, and reallocation of allocatable components allocated with an OpenMP allocator" "" { target *-*-* } 0 } diff --git a/gcc/tree-ssa-ccp.cc b/gcc/tree-ssa-ccp.cc index 03ff88afadd..ddcbaaaa417 100644 --- a/gcc/tree-ssa-ccp.cc +++ b/gcc/tree-ssa-ccp.cc @@ -2346,6 +2346,7 @@ evaluate_stmt (gimple *stmt) { case BUILT_IN_MALLOC: case BUILT_IN_REALLOC: + case BUILT_IN_GOMP_REALLOC: case BUILT_IN_CALLOC: case BUILT_IN_STRDUP: case BUILT_IN_STRNDUP: diff --git a/gcc/tree.cc b/gcc/tree.cc index 10c6e1ecc58..b626553a1e1 100644 --- a/gcc/tree.cc +++ b/gcc/tree.cc @@ -15023,6 +15023,8 @@ fndecl_dealloc_argno (tree fndecl) { case BUILT_IN_FREE: case BUILT_IN_REALLOC: + case BUILT_IN_GOMP_FREE: + case BUILT_IN_GOMP_REALLOC: return 0; default: break; diff --git a/libgomp/allocator.c b/libgomp/allocator.c index a8a80f8028d..58a4c57f883 100644 --- a/libgomp/allocator.c +++ b/libgomp/allocator.c @@ -35,6 +35,69 @@ #include <dlfcn.h> #endif +/* Keeping track whether a Fortran scalar allocatable/pointer has been + allocated via 'omp allocators'/'omp allocate'. */ + +struct fort_alloc_splay_tree_key_s { + void *ptr; +}; + +typedef struct fort_alloc_splay_tree_node_s *fort_alloc_splay_tree_node; +typedef struct fort_alloc_splay_tree_s *fort_alloc_splay_tree; +typedef struct fort_alloc_splay_tree_key_s *fort_alloc_splay_tree_key; + +static inline int +fort_alloc_splay_compare (fort_alloc_splay_tree_key x, fort_alloc_splay_tree_key y) +{ + if (x->ptr < y->ptr) + return -1; + if (x->ptr > y->ptr) + return 1; + return 0; +} +#define splay_tree_prefix fort_alloc +#define splay_tree_static +#include "splay-tree.h" + +#define splay_tree_prefix fort_alloc +#define splay_tree_static +#define splay_tree_c +#include "splay-tree.h" + +static struct fort_alloc_splay_tree_s fort_alloc_scalars; + +/* Add pointer as being alloced by GOMP_alloc. */ +void +GOMP_add_alloc (void *ptr) +{ + if (ptr == NULL) + return; + fort_alloc_splay_tree_node item; + item = gomp_malloc (sizeof (struct splay_tree_node_s)); + item->key.ptr = ptr; + item->left = NULL; + item->right = NULL; + fort_alloc_splay_tree_insert (&fort_alloc_scalars, item); +} + +/* Remove pointer, either called by FREE or by REALLOC, + either of them can change the allocation status. */ +bool +GOMP_is_alloc (void *ptr) +{ + struct fort_alloc_splay_tree_key_s needle; + fort_alloc_splay_tree_node n; + needle.ptr = ptr; + n = fort_alloc_splay_tree_lookup_node (&fort_alloc_scalars, &needle); + if (n) + { + fort_alloc_splay_tree_remove (&fort_alloc_scalars, &n->key); + free (n); + } + return n != NULL; +} + + #define omp_max_predefined_alloc omp_thread_mem_alloc /* These macros may be overridden in config/<target>/allocator.c. diff --git a/libgomp/libgomp.h b/libgomp/libgomp.h index fa29f428976..7831e7bffe3 100644 --- a/libgomp/libgomp.h +++ b/libgomp/libgomp.h @@ -1269,6 +1269,7 @@ reverse_splay_compare (reverse_splay_tree_key x, reverse_splay_tree_key y) } #define splay_tree_prefix reverse +#define splay_tree_static #include "splay-tree.h" /* Indirect target function splay-tree handling. */ diff --git a/libgomp/libgomp.map b/libgomp/libgomp.map index 90c401453b2..65901dff235 100644 --- a/libgomp/libgomp.map +++ b/libgomp/libgomp.map @@ -419,9 +419,15 @@ GOMP_5.1 { GOMP_5.1.1 { global: GOMP_taskwait_depend_nowait; - GOMP_target_map_indirect_ptr; } GOMP_5.1; +GOMP_5.1.2 { + global: + GOMP_add_alloc; + GOMP_is_alloc; + GOMP_target_map_indirect_ptr; +} GOMP_5.1.1; + OACC_2.0 { global: acc_get_num_devices; diff --git a/libgomp/libgomp.texi b/libgomp/libgomp.texi index 67a111265a0..cff2a2a0080 100644 --- a/libgomp/libgomp.texi +++ b/libgomp/libgomp.texi @@ -232,7 +232,9 @@ The OpenMP 4.5 specification is fully supported. @item Predefined memory spaces, memory allocators, allocator traits @tab Y @tab See also @ref{Memory allocation} @item Memory management routines @tab Y @tab -@item @code{allocate} directive @tab P @tab Only C and Fortran, only stack variables +@item @code{allocate} directive @tab P + @tab Only C for stack/automatic and Fortran for stack/automatic + and allocatable/pointer variables @item @code{allocate} clause @tab P @tab Initial support @item @code{use_device_addr} clause on @code{target data} @tab Y @tab @item @code{ancestor} modifier on @code{device} clause @tab Y @tab @@ -304,7 +306,7 @@ The OpenMP 4.5 specification is fully supported. @item @code{strict} modifier in the @code{grainsize} and @code{num_tasks} clauses of the @code{taskloop} construct @tab Y @tab @item @code{align} clause in @code{allocate} directive @tab P - @tab Only C and Fortran (and only stack variables) + @tab Only C and Fortran (and not for static variables) @item @code{align} modifier in @code{allocate} clause @tab Y @tab @item @code{thread_limit} clause to @code{target} construct @tab Y @tab @item @code{has_device_addr} clause to @code{target} construct @tab Y @tab @@ -402,7 +404,7 @@ to address of matching mapped list item per 5.1, Sect. 2.21.7.2 @tab N @tab @item Deprecation of @code{to} clause on declare target directive @tab N @tab @item Extended list of directives permitted in Fortran pure procedures @tab Y @tab -@item New @code{allocators} directive for Fortran @tab N @tab +@item New @code{allocators} directive for Fortran @tab Y @tab @item Deprecation of @code{allocate} directive for Fortran allocatables/pointers @tab N @tab @item Optional paired @code{end} directive with @code{dispatch} @tab N @tab @@ -5697,8 +5699,12 @@ The description below applies to: @option{-fstack-arrays}].) @item Using the @code{allocate} directive for variable in static memory is currently not supported (compile time error). -@item Using the @code{allocators} directive for Fortran pointers and - allocatables is currently not supported (compile time error). +@item In Fortran, the @code{allocators} directive and the executable + @code{allocate} directive for Fortran pointers and allocatables is + supported, but requires that files containing those directives has to be + compiled with @option{-fopenmp-allocators}. Additionally, all files that + might explicitly or implicitly deallocate memory allocated that way must + also be compiled with that option. @end itemize For the available predefined allocators and, as applicable, their associated diff --git a/libgomp/splay-tree.c b/libgomp/splay-tree.c index 02695d4b2bd..9e076f55180 100644 --- a/libgomp/splay-tree.c +++ b/libgomp/splay-tree.c @@ -131,7 +131,11 @@ splay_tree_splay (splay_tree sp, splay_tree_key key) /* Insert a new NODE into SP. The NODE shouldn't exist in the tree. */ +#ifdef splay_tree_static +__attribute__((unused)) static void +#else attribute_hidden void +#endif splay_tree_insert (splay_tree sp, splay_tree_node node) { int comparison = 0; @@ -167,7 +171,11 @@ splay_tree_insert (splay_tree sp, splay_tree_node node) /* Remove node with KEY from SP. It is not an error if it did not exist. */ +#ifdef splay_tree_static +__attribute__((unused)) static void +#else attribute_hidden void +#endif splay_tree_remove (splay_tree sp, splay_tree_key key) { splay_tree_splay (sp, key); @@ -202,7 +210,28 @@ splay_tree_remove (splay_tree sp, splay_tree_key key) /* Lookup KEY in SP, returning NODE if present, and NULL otherwise. */ +#ifdef splay_tree_static +__attribute__((unused)) static splay_tree_node +#else +attribute_hidden splay_tree_node +#endif +splay_tree_lookup_node (splay_tree sp, splay_tree_key key) +{ + splay_tree_splay (sp, key); + + if (sp->root && splay_compare (&sp->root->key, key) == 0) + return sp->root; + else + return NULL; +} + +/* Likewise but return the key. */ + +#ifdef splay_tree_static +__attribute__((unused)) static splay_tree_key +#else attribute_hidden splay_tree_key +#endif splay_tree_lookup (splay_tree sp, splay_tree_key key) { splay_tree_splay (sp, key); @@ -231,7 +260,11 @@ splay_tree_foreach_internal (splay_tree_node node, splay_tree_callback func, /* Run FUNC on each of the nodes in SP. */ +#ifdef splay_tree_static +__attribute__((unused)) static void +#else attribute_hidden void +#endif splay_tree_foreach (splay_tree sp, splay_tree_callback func, void *data) { splay_tree_foreach_internal (sp->root, func, data); @@ -253,8 +286,13 @@ splay_tree_foreach_internal_lazy (splay_tree_node node, return splay_tree_foreach_internal_lazy (node->right, func, data); } +#ifdef splay_tree_static +__attribute__((unused)) static void +#else attribute_hidden void -splay_tree_foreach_lazy (splay_tree sp, splay_tree_callback_stop func, void *data) +#endif +splay_tree_foreach_lazy (splay_tree sp, splay_tree_callback_stop func, + void *data) { splay_tree_foreach_internal_lazy (sp->root, func, data); } diff --git a/libgomp/splay-tree.h b/libgomp/splay-tree.h index 978f1e49800..04ff94739b0 100644 --- a/libgomp/splay-tree.h +++ b/libgomp/splay-tree.h @@ -35,6 +35,8 @@ typedef struct splay_tree_key_s *splay_tree_key; define splay_tree_key_s structure, and define splay_compare inline function. + Define splay_tree_static to mark all functions as static. + Alternatively, they can define splay_tree_prefix macro before including this header and then all the above types, the splay_compare function and the splay_tree_{lookup,insert_remove} @@ -72,6 +74,8 @@ typedef struct splay_tree_key_s *splay_tree_key; splay_tree_name (splay_tree_prefix, splay_compare) # define splay_tree_lookup \ splay_tree_name (splay_tree_prefix, splay_tree_lookup) +# define splay_tree_lookup_node \ + splay_tree_name (splay_tree_prefix, splay_tree_lookup_node) # define splay_tree_insert \ splay_tree_name (splay_tree_prefix, splay_tree_insert) # define splay_tree_remove \ @@ -105,11 +109,19 @@ struct splay_tree_s { typedef void (*splay_tree_callback) (splay_tree_key, void *); typedef int (*splay_tree_callback_stop) (splay_tree_key, void *); +#ifndef splay_tree_static extern splay_tree_key splay_tree_lookup (splay_tree, splay_tree_key); +extern splay_tree_node splay_tree_lookup_node (splay_tree, splay_tree_key); extern void splay_tree_insert (splay_tree, splay_tree_node); extern void splay_tree_remove (splay_tree, splay_tree_key); extern void splay_tree_foreach (splay_tree, splay_tree_callback, void *); extern void splay_tree_foreach_lazy (splay_tree, splay_tree_callback_stop, void *); +#endif + +#ifdef splay_tree_static_unused_attr +# undef splay_tree_static_unused_attr +#endif + #else /* splay_tree_c */ # ifdef splay_tree_prefix # include "splay-tree.c" @@ -117,6 +129,10 @@ extern void splay_tree_foreach_lazy (splay_tree, splay_tree_callback_stop, void # undef splay_tree_c #endif /* #ifndef splay_tree_c */ +#ifdef splay_tree_static +# undef splay_tree_static +#endif + #ifdef splay_tree_prefix # undef splay_tree_name_1 # undef splay_tree_name @@ -128,6 +144,7 @@ extern void splay_tree_foreach_lazy (splay_tree, splay_tree_callback_stop, void # undef splay_tree_key # undef splay_compare # undef splay_tree_lookup +# undef splay_tree_lookup_node # undef splay_tree_insert # undef splay_tree_remove # undef splay_tree_foreach diff --git a/libgomp/target.c b/libgomp/target.c index f30c20255d3..0637d34f125 100644 --- a/libgomp/target.c +++ b/libgomp/target.c @@ -47,6 +47,7 @@ /* Define another splay tree instantiation - for reverse offload. */ #define splay_tree_prefix reverse +#define splay_tree_static #define splay_tree_c #include "splay-tree.h" diff --git a/libgomp/testsuite/libgomp.fortran/allocators-1.f90 b/libgomp/testsuite/libgomp.fortran/allocators-1.f90 new file mode 100644 index 00000000000..935a37cd959 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/allocators-1.f90 @@ -0,0 +1,68 @@ +! { dg-additional-options "-fopenmp-allocators -fdump-tree-original" } +module m + use omp_lib + use iso_c_binding, only: c_intptr_t + implicit none (type,external) + integer(omp_allocator_handle_kind) :: handle + integer(c_intptr_t) :: iptr +end module m + +subroutine scalar + use m + implicit none (type,external) + integer :: i + integer, allocatable :: SSS + i = 5 ! required executive statement before 'omp allocators' + !$omp allocate allocator(handle) + allocate(SSS) + if (mod (loc (sss), 64) /= 0) stop 1 + deallocate(SSS) + allocate(SSS) +end +! { dg-final { scan-tree-dump-times "sss = \\(integer\\(kind=4\\) \\*\\) __builtin_GOMP_alloc \\(4, 4, D\\.\[0-9\]+\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "GOMP_add_alloc \\(sss\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "if \\(GOMP_is_alloc \\(sss\\)\\)" 2 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(sss, 0B\\);" 2 "original" } } + +subroutine array + use m + implicit none (type,external) + integer :: i + integer, allocatable :: A(:) + i = 5 ! required executive statement before 'omp allocators' + !$omp allocate allocator(handle) align(512) + allocate(A(5)) + if (mod (loc (A), 512) /= 0) stop 2 + A=[1] + if (mod (loc (A), 64) /= 0) stop 3 + deallocate(A) + A=[1] + deallocate(A) + call omp_set_default_allocator (handle) + !$omp allocate + allocate(A(7)) + if (mod (loc (A), 64) /= 0) stop 4 +end +! { dg-final { scan-tree-dump-times "a.dtype = {.elem_len=4, .version=0, .rank=1, .type=1};" 5 "original" } } +! { dg-final { scan-tree-dump-times "\\.elem_len=4" 5 "original" } } +! { dg-final { scan-tree-dump-times "a.data = \\(void \\* restrict\\) __builtin_GOMP_alloc \\(512, 20, D\\.\[0-9\]+\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "a.data = \\(void \\* restrict\\) __builtin_GOMP_alloc \\(4, 28, 0B\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "a.dtype.version = 1;" 2 "original" } } +! { dg-final { scan-tree-dump-times "a.data = \\(void \\* restrict\\) \\(a.dtype.version == 1 \\? __builtin_omp_realloc \\(\\(void \\*\\) a.data, 4, 0B, 0B\\) : __builtin_realloc \\(\\(void \\*\\) a.data, 4\\)\\);" 2 "original" } } +! { dg-final { scan-tree-dump-times "if \\(a.dtype.version == 1\\)" 3 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(\\(integer\\(kind=4\\)\\\[0:\\\] \\* restrict\\) a.data, 0B\\);" 3 "original" } } +! { dg-final { scan-tree-dump-times "a.dtype.version = 0;" 3 "original" } } + +program main + use m + implicit none (type,external) + external :: scalar, array + type (omp_alloctrait), parameter :: traits(*) & + = [omp_alloctrait(omp_atk_sync_hint, omp_atv_contended), & + omp_alloctrait(omp_atk_alignment, 64)] + handle = omp_init_allocator (omp_high_bw_mem_alloc, size(traits), traits) + call scalar + call array + call omp_destroy_allocator (handle) +end + diff --git a/libgomp/testsuite/libgomp.fortran/allocators-2.f90 b/libgomp/testsuite/libgomp.fortran/allocators-2.f90 new file mode 100644 index 00000000000..c42fbd31e3e --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/allocators-2.f90 @@ -0,0 +1,101 @@ +! { dg-additional-options "-fopenmp-allocators" } +module m + implicit none (type, external) + type t + integer, allocatable :: Acomp, Bcomp(:) + end type t + +contains + +subroutine intent_out(aa, bb, cc, dd, ee, ff) + integer, allocatable,intent(out) :: aa, bb(:) + type(t), intent(out) :: cc, dd(4) + type(t), allocatable, intent(out) :: ee, ff(:) +end + +subroutine q(qa, qb, qc, qd, qe, qf) + integer, allocatable :: qa, qb(:) + type(t) :: qc, qd(4) + type(t), allocatable :: qe, qf(:) + call intent_out (qa, qb, qc, qd, qe, qf) +end subroutine q + +subroutine r + integer, allocatable :: r1, r2(:) + type(t) :: r3, r4(4) + type(t), allocatable :: r5, r6(:) + + call q(r1,r2,r3,r4,r5,r6) + + allocate(r1,r2(3)) + allocate(r5,r6(4)) + allocate(r3%Acomp, r3%Bcomp(2)) + allocate(r4(2)%Acomp, r4(2)%Bcomp(2)) + allocate(r5%Acomp, r5%Bcomp(2)) + allocate(r6(3)%Acomp, r6(3)%Bcomp(2)) + !$omp allocate align(128) + allocate(r4(3)%Acomp, r4(3)%Bcomp(2), & + r6(1)%Acomp, r6(1)%Bcomp(2)) + if (mod (loc (r4(3)%Acomp), 128) /= 0) stop 1 + if (mod (loc (r4(3)%Bcomp), 128) /= 0) stop 2 + if (mod (loc (r6(1)%Acomp), 128) /= 0) stop 3 + if (mod (loc (r6(1)%Bcomp), 128) /= 0) stop 3 + call q(r1,r2,r3,r4,r5,r6) + + !$omp allocate align(64) + allocate(r1,r2(3)) + if (mod (loc (r1), 64) /= 0) stop 1 + if (mod (loc (r2), 64) /= 0) stop 1 + !$omp allocate align(64) + allocate(r5,r6(4)) + if (mod (loc (r5), 64) /= 0) stop 1 + if (mod (loc (r6), 64) /= 0) stop 1 + !$omp allocate align(64) + allocate(r3%Acomp, r3%Bcomp(2)) + if (mod (loc (r3%Acomp), 64) /= 0) stop 1 + if (mod (loc (r3%Bcomp), 64) /= 0) stop 1 + !$omp allocate align(64) + allocate(r4(2)%Acomp, r4(2)%Bcomp(2)) + if (mod (loc (r4(2)%Acomp), 64) /= 0) stop 1 + if (mod (loc (r4(2)%Bcomp), 64) /= 0) stop 1 + !$omp allocate align(64) + allocate(r5%Acomp, r5%Bcomp(2)) + if (mod (loc (r5%Acomp), 64) /= 0) stop 1 + if (mod (loc (r5%Bcomp), 64) /= 0) stop 1 + !$omp allocate align(64) + allocate(r6(3)%Acomp, r6(3)%Bcomp(2)) + if (mod (loc (r6(3)%Acomp), 64) /= 0) stop 1 + if (mod (loc (r6(3)%Bcomp), 64) /= 0) stop 1 + !$omp allocate align(128) + allocate(r4(3)%Acomp, r4(3)%Bcomp(2), & + r6(1)%Acomp, r6(1)%Bcomp(2)) + if (mod (loc (r4(3)%Acomp), 128) /= 0) stop 1 + if (mod (loc (r4(3)%Bcomp), 128) /= 0) stop 2 + if (mod (loc (r6(1)%Acomp), 128) /= 0) stop 3 + if (mod (loc (r6(1)%Bcomp), 128) /= 0) stop 3 + call q(r1,r2,r3,r4,r5,r6) +end subroutine r +end + +subroutine s + use m, only : t + implicit none (type, external) + type(t) :: xx + integer :: i, iiiiii + i = 4 + !$omp allocate + allocate(xx%Acomp, xx%Bcomp(4)) + deallocate(xx%Acomp, xx%Bcomp) + + !$omp allocate + allocate(xx%Acomp, xx%Bcomp(4)) + xx = t(1, [1,2]) +end + +program main + use m, only: r + implicit none (type, external) + external s + call s + call r +end diff --git a/libgomp/testsuite/libgomp.fortran/allocators-3.f90 b/libgomp/testsuite/libgomp.fortran/allocators-3.f90 new file mode 100644 index 00000000000..2e05939a8b6 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/allocators-3.f90 @@ -0,0 +1,25 @@ +! { dg-additional-options "-fdump-tree-original -fopenmp-allocators" } + +subroutine s + character(:), allocatable :: s1,s2 + + !$omp allocators allocate(s1) + allocate(character(len=3) :: s1) + + !$omp allocators allocate(s2) + allocate(character(len=5) :: s2) + + s2(1:5) = "12" + s1 = trim(s2) +end +! { dg-final { scan-tree-dump-times "s1 = \\(character\\(kind=1\\)\\\[1:.s1\\\] \\*\\) __builtin_GOMP_alloc \\(1, 3, 0B\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "s2 = \\(character\\(kind=1\\)\\\[1:.s2\\\] \\*\\) __builtin_GOMP_alloc \\(1, 5, 0B\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "s1 = \\(character\\(kind=1\\)\\\[1:.s1\\\] \\*\\) \\(D\\.\[0-9\]+ \\? __builtin_omp_realloc \\(\\(void \\*\\) s1, MAX_EXPR <\\(sizetype\\) len.1, 1>, 0B, 0B\\) : __builtin_realloc \\(\\(void \\*\\) s1, MAX_EXPR <\\(sizetype\\) len.1, 1>\\)\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "GOMP_add_alloc \\(s1\\);" 2 "original" } } +! { dg-final { scan-tree-dump-times "OMP_add_alloc \\(s2\\);" 1 "original" } } +! { dg-final { scan-tree-dump-times "if \\(GOMP_is_alloc \\(s2\\)\\)" 1 "original" } } +! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(s2, 0B\\);" 1 "original" } } + + +call s +end diff --git a/libgomp/testsuite/libgomp.fortran/allocators-4.f90 b/libgomp/testsuite/libgomp.fortran/allocators-4.f90 new file mode 100644 index 00000000000..12689ea41ac --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/allocators-4.f90 @@ -0,0 +1,57 @@ +! { dg-additional-options "-fopenmp-allocators" } +module m +implicit none +type t + integer, allocatable :: Acomp, Bcomp(:) + class(*), allocatable :: Ccomp, Dcomp(:) +end type t +contains + +subroutine intout(c,d,e,f) +implicit none +class(t), intent(out) :: c,d(4) +class(t), allocatable, intent(out) :: e,f(:) +end + +subroutine q(c,d,e,f) +implicit none +class(t) :: c,d(4) +class(t), allocatable :: e,f(:) +call intout(c,d,e,f) +end subroutine q + +subroutine s +implicit none +type(t) :: xx +class(t), allocatable :: yy +integer :: i, iiiiii +i = 4 +!$omp allocate +allocate(xx%Acomp, xx%Bcomp(4)) +deallocate(xx%Acomp, xx%Bcomp) + +!$omp allocate +allocate(integer :: xx%Ccomp, xx%Dcomp(4)) +deallocate(xx%Ccomp, xx%Dcomp) + +!$omp allocators allocate(yy) +allocate(t :: yy) + +!$omp allocate +allocate(real :: xx%Ccomp, xx%Dcomp(4)) +deallocate(xx%Ccomp, xx%Dcomp) + +!$omp allocate +allocate(xx%Acomp, xx%Bcomp(4)) +!$omp allocate +allocate(logical :: xx%Ccomp, xx%Dcomp(4)) + +iiiiii = 555 +xx = t(1, [1,2]) +end + +end module + +use m +call s +end diff --git a/libgomp/testsuite/libgomp.fortran/allocators-5.f90 b/libgomp/testsuite/libgomp.fortran/allocators-5.f90 new file mode 100644 index 00000000000..87088630197 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/allocators-5.f90 @@ -0,0 +1,27 @@ +! { dg-additional-options "-fopenmp-allocators" } +module m +contains +subroutine s(a,b,c,d) +integer, allocatable :: A, B +integer, allocatable :: C(:), D(:) + +!$omp allocators allocate(A,B) +allocate(A,B) +call move_alloc(A,B) + +!$omp allocators allocate(C,D) +allocate(C(5),D(5)) +call move_alloc(C,D) +end + +subroutine q() +integer, allocatable :: A, B +integer, allocatable :: C(:), D(:) + +call s(a,b,c,d) +end +end + +use m +call q +end |