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.
This commit is contained in:
Tobias Burnus
parent
47575ec9ed
commit
d4b6d14792
45 changed files with 1113 additions and 116 deletions
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
@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
|
||||
@opindex fopenacc
|
||||
@cindex OpenACC accelerator programming
|
||||
@item -fopenacc
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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. */
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
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);
|
||||
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);
|
||||
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
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -4841,6 +4841,30 @@ gfc_trans_oacc_wait_directive (gfc_code *code)
|
|||
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)
|
||||
{
|
||||
|
|
@ -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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
{
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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",
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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" } }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
10
gcc/testsuite/gfortran.dg/gomp/allocate-16.f90
Normal file
10
gcc/testsuite/gfortran.dg/gomp/allocate-16.f90
Normal file
|
|
@ -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 }
|
||||
|
|
@ -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))
|
||||
|
|
|
|||
36
gcc/testsuite/gfortran.dg/gomp/allocators-3.f90
Normal file
36
gcc/testsuite/gfortran.dg/gomp/allocators-3.f90
Normal file
|
|
@ -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
|
||||
9
gcc/testsuite/gfortran.dg/gomp/allocators-4.f90
Normal file
9
gcc/testsuite/gfortran.dg/gomp/allocators-4.f90
Normal file
|
|
@ -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 }
|
||||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
|
|
@ -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. */
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
||||
|
|
|
|||
68
libgomp/testsuite/libgomp.fortran/allocators-1.f90
Normal file
68
libgomp/testsuite/libgomp.fortran/allocators-1.f90
Normal file
|
|
@ -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
|
||||
|
||||
101
libgomp/testsuite/libgomp.fortran/allocators-2.f90
Normal file
101
libgomp/testsuite/libgomp.fortran/allocators-2.f90
Normal file
|
|
@ -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
|
||||
25
libgomp/testsuite/libgomp.fortran/allocators-3.f90
Normal file
25
libgomp/testsuite/libgomp.fortran/allocators-3.f90
Normal file
|
|
@ -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
|
||||
57
libgomp/testsuite/libgomp.fortran/allocators-4.f90
Normal file
57
libgomp/testsuite/libgomp.fortran/allocators-4.f90
Normal file
|
|
@ -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
|
||||
27
libgomp/testsuite/libgomp.fortran/allocators-5.f90
Normal file
27
libgomp/testsuite/libgomp.fortran/allocators-5.f90
Normal file
|
|
@ -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
|
||||
Loading…
Add table
Reference in a new issue