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,
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:
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:
#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)
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;
-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
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
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.
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);
&& 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;
&& 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. */
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:
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;
}
+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
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;
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;
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)
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)
{
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,
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;
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
{
/* 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 *,
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);
/* 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
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,
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);
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);
}
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)
{
{
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:
}
}
}
+
+/* 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);
+}
/* 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;
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.
/* 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. */
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
{
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 */
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);
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)
} */
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;
/* 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);
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);
}
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;
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;
{
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);
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)
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;
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));
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))
{
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))
break;
case EXEC_ALLOCATE:
- res = gfc_trans_allocate (code);
+ res = gfc_trans_allocate (code, NULL);
break;
case EXEC_DEALLOCATE:
/* 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,
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);
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,
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:
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:
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);
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:
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;
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",
*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
! { 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" } }
!$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
--- /dev/null
+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 }
+! { dg-additional-options "-fopenmp-allocators" }
module my_omp_lib
use iso_c_binding, only: c_intptr_t
!use omp_lib
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)
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))
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))
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))
--- /dev/null
+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
--- /dev/null
+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 }
{
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:
{
case BUILT_IN_FREE:
case BUILT_IN_REALLOC:
+ case BUILT_IN_GOMP_FREE:
+ case BUILT_IN_GOMP_REALLOC:
return 0;
default:
break;
#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.
}
#define splay_tree_prefix reverse
+#define splay_tree_static
#include "splay-tree.h"
/* Indirect target function splay-tree handling. */
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;
@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
@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
@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
@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
/* 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;
/* 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);
/* 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);
/* 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);
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);
}
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}
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 \
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"
# 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
# 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
/* 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"
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
projects / thirdparty / gcc.git / commitdiff
