procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fortran: Support OpenMP's 'allocate' directive for stack vars

Browse source 
gcc/fortran/ChangeLog:

	* gfortran.h (ext_attr_t): Add omp_allocate flag.
	* match.cc (gfc_free_omp_namelist): Void deleting same
	u2.allocator multiple times now that a sequence can use
	the same one.
	* openmp.cc (gfc_match_omp_clauses, gfc_match_omp_allocate): Use
	same allocator expr multiple times.
	(is_predefined_allocator): Make static.
	(gfc_resolve_omp_allocate): Update/extend restriction checks;
	remove sorry message.
	(resolve_omp_clauses): Reject corarrays in allocate/allocators
	directive.
	* parse.cc (check_omp_allocate_stmt): Permit procedure pointers
	here (rejected later) for less misleading diagnostic.
	* trans-array.cc (gfc_trans_auto_array_allocation): Propagate
	size for GOMP_alloc and location to which it should be added to.
	* trans-decl.cc (gfc_trans_deferred_vars): Handle 'omp allocate'
	for stack variables; sorry for static variables/common blocks.
	* trans-openmp.cc (gfc_trans_omp_clauses): Evaluate 'allocate'
	clause's allocator only once; fix adding expressions to the
	block.
	(gfc_trans_omp_single): Pass a block to gfc_trans_omp_clauses.

gcc/ChangeLog:

	* gimplify.cc (gimplify_bind_expr): Handle Fortran's
	'omp allocate' for stack variables.

libgomp/ChangeLog:

	* libgomp.texi (OpenMP Impl. Status): Mention that Fortran now
	supports the allocate directive for stack variables.
	* testsuite/libgomp.fortran/allocate-5.f90: New test.
	* testsuite/libgomp.fortran/allocate-6.f90: New test.
	* testsuite/libgomp.fortran/allocate-7.f90: New test.
	* testsuite/libgomp.fortran/allocate-8.f90: New test.

gcc/testsuite/ChangeLog:

	* c-c++-common/gomp/allocate-14.c: Fix directive name.
	* c-c++-common/gomp/allocate-15.c: Likewise.
	* c-c++-common/gomp/allocate-9.c: Fix comment typo.
	* gfortran.dg/gomp/allocate-4.f90: Remove sorry dg-error.
	* gfortran.dg/gomp/allocate-7.f90: Likewise.
	* gfortran.dg/gomp/allocate-10.f90: New test.
	* gfortran.dg/gomp/allocate-11.f90: New test.
	* gfortran.dg/gomp/allocate-12.f90: New test.
	* gfortran.dg/gomp/allocate-13.f90: New test.
	* gfortran.dg/gomp/allocate-14.f90: New test.
	* gfortran.dg/gomp/allocate-15.f90: New test.
	* gfortran.dg/gomp/allocate-8.f90: New test.
	* gfortran.dg/gomp/allocate-9.f90: New test.
This commit is contained in:
Tobias Burnus 2023-10-14 11:07:47 +02:00
parent cb01192423
commit 969f5c3eaa
26 changed files with 1484 additions and 99 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
gcc/fortran/gfortran.h
View file

@ -1000,6 +1000,7 @@ typedef struct
unsigned omp_declare_target:1;
unsigned omp_declare_target_link:1;
ENUM_BITFIELD (gfc_omp_device_type) omp_device_type:2;
unsigned omp_allocate:1;
/* Mentioned in OACC DECLARE. */
unsigned oacc_declare_create:1;

9
gcc/fortran/match.cc
View file

@ -5541,6 +5541,7 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns,
bool free_mem_traits_space)
{
gfc_omp_namelist *n;
gfc_expr *last_allocator = NULL;
for (; name; name = n)
{
@ -5552,7 +5553,13 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns,
if (free_ns)
gfc_free_namespace (name->u2.ns);
else if (free_align_allocator)
gfc_free_expr (name->u2.allocator);
{
if (last_allocator != name->u2.allocator)
{
last_allocator = name->u2.allocator;
gfc_free_expr (name->u2.allocator);
}
}
else if (free_mem_traits_space)
{ } /* name->u2.traits_sym: shall not call gfc_free_symbol here. */
else if (name->u2.udr)

62
gcc/fortran/openmp.cc
View file

@ -2032,11 +2032,9 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
for (gfc_omp_namelist *n = *head; n; n = n->next)
{
n->u2.allocator = ((allocator)
? gfc_copy_expr (allocator) : NULL);
n->u2.allocator = allocator;
n->u.align = (align) ? gfc_copy_expr (align) : NULL;
}
gfc_free_expr (allocator);
gfc_free_expr (align);
continue;
}
@ -4547,9 +4545,8 @@ gfc_match_omp_allocate (void)
for (; vars; vars = vars->next)
{
vars->u.align = (align) ? gfc_copy_expr (align) : NULL;
vars->u2.allocator = ((allocator) ? gfc_copy_expr (allocator) : NULL);
vars->u2.allocator = allocator;
}
gfc_free_expr (allocator);
gfc_free_expr (align);
}
return MATCH_YES;
@ -7191,7 +7188,7 @@ resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
/* Assume that a constant expression in the range 1 (omp_default_mem_alloc)
to 8 (omp_thread_mem_alloc) range is fine. The original symbol name is
already lost during matching via gfc_match_expr. */
bool
static bool
is_predefined_allocator (gfc_expr *expr)
{
return (gfc_resolve_expr (expr)
@ -7209,10 +7206,20 @@ is_predefined_allocator (gfc_expr *expr)
void
gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
{
for (gfc_omp_namelist *n = list; n; n = n->next)
n->sym->mark = 0;
for (gfc_omp_namelist *n = list; n; n = n->next)
{
if (n->sym->attr.result || n->sym->result == n->sym)
{
gfc_error ("Unexpected function-result variable %qs at %L in "
"declarative !$OMP ALLOCATE", n->sym->name, &n->where);
continue;
}
if (ns->omp_allocate->sym->attr.proc_pointer)
{
gfc_error ("Procedure pointer %qs not supported with !$OMP "
"ALLOCATE at %L", n->sym->name, &n->where);
continue;
}
if (n->sym->attr.flavor != FL_VARIABLE)
{
gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE "
@ -7220,8 +7227,7 @@ gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
&n->where);
continue;
}
if (ns != n->sym->ns || n->sym->attr.use_assoc
|| n->sym->attr.host_assoc || n->sym->attr.imported)
if (ns != n->sym->ns || n->sym->attr.use_assoc || n->sym->attr.imported)
{
gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE shall be"
" in the same scope as the variable declaration",
@ -7234,7 +7240,13 @@ gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
"declarative !$OMP ALLOCATE", n->sym->name, &n->where);
continue;
}
if (n->sym->mark)
if (n->sym->attr.codimension)
{
gfc_error ("Unexpected coarray argument %qs as argument at %L to "
"declarative !$OMP ALLOCATE", n->sym->name, &n->where);
continue;
}
if (n->sym->attr.omp_allocate)
{
if (n->sym->attr.in_common)
{
@ -7249,7 +7261,28 @@ gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
n->sym->name, &n->where);
continue;
}
n->sym->mark = 1;
/* For 'equivalence(a,b)', a 'union_type {<type> a,b} equiv.0' is created
with a value expression for 'a' as 'equiv.0.a' (likewise for b); while
this can be handled, EQUIVALENCE is marked as obsolescent since Fortran
2018 and also not widely used. However, it could be supported,
if needed. */
if (n->sym->attr.in_equivalence)
{
gfc_error ("Sorry, EQUIVALENCE object %qs not supported with !$OMP "
"ALLOCATE at %L", n->sym->name, &n->where);
continue;
}
/* Similar for Cray pointer/pointee - they could be implemented but as
common vendor extension but nowadays rarely used and requiring
-fcray-pointer, there is no need to support them. */
if (n->sym->attr.cray_pointer || n->sym->attr.cray_pointee)
{
gfc_error ("Sorry, Cray pointers and pointees such as %qs are not "
"supported with !$OMP ALLOCATE at %L",
n->sym->name, &n->where);
continue;
}
n->sym->attr.omp_allocate = 1;
if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
&& CLASS_DATA (n->sym)->attr.allocatable)
|| (n->sym->ts.type != BT_CLASS && n->sym->attr.allocatable))
@ -7307,8 +7340,6 @@ gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
"%<omp_allocator_handle_kind%> kind at %L",
&n->u2.allocator->where);
}
gfc_error ("Sorry, declarative !$OMP ALLOCATE at %L not yet supported",
&list->where);
}
/* Resolve ASSUME's and ASSUMES' assumption clauses. Note that absent/contains
@ -7897,6 +7928,9 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
{
if (n->sym == NULL)
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)

8
gcc/fortran/parse.cc
View file

@ -833,18 +833,18 @@ check_omp_allocate_stmt (locus *loc)
&n->expr->where, gfc_ascii_statement (ST_OMP_ALLOCATE));
return false;
}
/* Procedure pointers are not allocatable; hence, we do not regard them as
pointers here - and reject them later in gfc_resolve_omp_allocate. */
bool alloc_ptr;
if (n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok)
alloc_ptr = (CLASS_DATA (n->sym)->attr.allocatable
|| CLASS_DATA (n->sym)->attr.class_pointer);
else
alloc_ptr = (n->sym->attr.allocatable || n->sym->attr.pointer
|| n->sym->attr.proc_pointer);
alloc_ptr = n->sym->attr.allocatable || n->sym->attr.pointer;
if (alloc_ptr
|| (n->sym->ns && n->sym->ns->proc_name
&& (n->sym->ns->proc_name->attr.allocatable
|| n->sym->ns->proc_name->attr.pointer
|| n->sym->ns->proc_name->attr.proc_pointer)))
|| n->sym->ns->proc_name->attr.pointer)))
has_allocatable = true;
else
has_non_allocatable = true;

28
gcc/fortran/trans-array.cc
View file

@ -82,6 +82,9 @@ along with GCC; see the file COPYING3. If not see
#include "tree.h"
#include "gfortran.h"
#include "gimple-expr.h"
#include "tree-iterator.h"
#include "stringpool.h" /* Required by "attribs.h". */
#include "attribs.h" /* For lookup_attribute. */
#include "trans.h"
#include "fold-const.h"
#include "constructor.h"
@ -6770,6 +6773,15 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
gimplifier to allocate storage, and all that good stuff. */
tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
gfc_add_expr_to_block (&init, tmp);
if (sym->attr.omp_allocate)
{
/* Save location of size calculation to ensure GOMP_alloc is placed
after it. */
tree omp_alloc = lookup_attribute ("omp allocate",
DECL_ATTRIBUTES (decl));
TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
= build_tree_list (NULL_TREE, tsi_stmt (tsi_last (init.head)));
}
}
if (onstack)
@ -6798,8 +6810,22 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
return;
}
if (sym->attr.omp_allocate)
{
/* The size is the number of elements in the array, so multiply by the
size of an element to get the total size. */
tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
size, fold_convert (gfc_array_index_type, tmp));
size = gfc_evaluate_now (size, &init);
if (flag_stack_arrays)
tree omp_alloc = lookup_attribute ("omp allocate",
DECL_ATTRIBUTES (decl));
TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
= build_tree_list (size, NULL_TREE);
space = NULL_TREE;
}
else if (flag_stack_arrays)
{
gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
space = build_decl (gfc_get_location (&sym->declared_at),

126
gcc/fortran/trans-decl.cc
View file

@ -48,6 +48,7 @@ along with GCC; see the file COPYING3. If not see
#include "gimplify.h"
#include "omp-general.h"
#include "attr-fnspec.h"
#include "tree-iterator.h"
#define MAX_LABEL_VALUE 99999
@ -4652,6 +4653,36 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
init_intent_out_dt (proc_sym, block);
gfc_restore_backend_locus (&loc);
/* For some reasons, internal procedures point to the parent's
namespace. Top-level procedure and variables inside BLOCK are fine. */
gfc_namespace *omp_ns = proc_sym->ns;
if (proc_sym->ns->proc_name != proc_sym)
for (omp_ns = proc_sym->ns->contained; omp_ns;
omp_ns = omp_ns->sibling)
if (omp_ns->proc_name == proc_sym)
break;
/* Add 'omp allocate' attribute for gfc_trans_auto_array_allocation and
unset attr.omp_allocate for 'omp allocate allocator(omp_default_mem_alloc),
which has the normal codepath except for an invalid-use check in the ME.
The main processing happens later in this function. */
for (struct gfc_omp_namelist *n = omp_ns ? omp_ns->omp_allocate : NULL;
n; n = n->next)
if (!TREE_STATIC (n->sym->backend_decl))
{
/* Add empty entries - described and to be filled below. */
tree tmp = build_tree_list (NULL_TREE, NULL_TREE);
TREE_CHAIN (tmp) = build_tree_list (NULL_TREE, NULL_TREE);
DECL_ATTRIBUTES (n->sym->backend_decl)
= tree_cons (get_identifier ("omp allocate"), tmp,
DECL_ATTRIBUTES (n->sym->backend_decl));
if (n->u.align == NULL
&& n->u2.allocator != NULL
&& n->u2.allocator->expr_type == EXPR_CONSTANT
&& mpz_cmp_si (n->u2.allocator->value.integer, 1) == 0)
n->sym->attr.omp_allocate = 0;
}
for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
{
bool alloc_comp_or_fini = (sym->ts.type == BT_DERIVED)
@ -5105,6 +5136,101 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
gcc_unreachable ();
}
/* Handle 'omp allocate'. This has to be after the block above as
gfc_add_init_cleanup (..., init, ...) puts 'init' of later calls
before earlier calls. The code is a bit more complex as gfortran does
not really work with bind expressions / BIND_EXPR_VARS properly, i.e.
gimplify_bind_expr needs some help for placing the GOMP_alloc. Thus,
we pass on the location of the allocate-assignment expression and,
if the size is not constant, the size variable if Fortran computes this
differently. We also might add an expression location after which the
code has to be added, e.g. for character len expressions, which affect
the UNIT_SIZE. */
gfc_expr *last_allocator = NULL;
if (omp_ns && omp_ns->omp_allocate)
{
if (!block->init || TREE_CODE (block->init) != STATEMENT_LIST)
{
tree tmp = build1_v (LABEL_EXPR, gfc_build_label_decl (NULL_TREE));
append_to_statement_list (tmp, &block->init);
}
if (!block->cleanup || TREE_CODE (block->cleanup) != STATEMENT_LIST)
{
tree tmp = build1_v (LABEL_EXPR, gfc_build_label_decl (NULL_TREE));
append_to_statement_list (tmp, &block->cleanup);
}
}
tree init_stmtlist = block->init;
tree cleanup_stmtlist = block->cleanup;
se.expr = NULL_TREE;
for (struct gfc_omp_namelist *n = omp_ns ? omp_ns->omp_allocate : NULL;
n; n = n->next)
if (!TREE_STATIC (n->sym->backend_decl))
{
tree align = (n->u.align ? gfc_conv_constant_to_tree (n->u.align)
: NULL_TREE);
if (last_allocator != n->u2.allocator)
{
location_t loc = input_location;
gfc_init_se (&se, NULL);
if (n->u2.allocator)
{
input_location = gfc_get_location (&n->u2.allocator->where);
gfc_conv_expr (&se, n->u2.allocator);
}
/* We need to evalulate non-constants - also to find the location
after which the GOMP_alloc has to be added to - also as BLOCK
does not yield a new BIND_EXPR_BODY. */
if (n->u2.allocator
&& (!(CONSTANT_CLASS_P (se.expr) && DECL_P (se.expr))
|| se.pre.head || se.post.head))
{
stmtblock_t tmpblock;
gfc_init_block (&tmpblock);
se.expr = gfc_evaluate_now (se.expr, &tmpblock);
/* First post then pre because the new code is inserted
at the top. */
gfc_add_init_cleanup (block, gfc_finish_block (&se.post), NULL);
gfc_add_init_cleanup (block, gfc_finish_block (&tmpblock),
NULL);
gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), NULL);
}
last_allocator = n->u2.allocator;
input_location = loc;
}
/* 'omp allocate( {purpose: allocator, value: align},
{purpose: init-stmtlist, value: cleanup-stmtlist},
{purpose: size-var, value: last-size-expr}}
where init-stmt/cleanup-stmt is the STATEMENT list to find the
try-final block; last-size-expr is to find the location after
which to add the code and 'size-var' is for the proper size, cf.
gfc_trans_auto_array_allocation - either or both of the latter
can be NULL. */
tree tmp = lookup_attribute ("omp allocate",
DECL_ATTRIBUTES (n->sym->backend_decl));
tmp = TREE_VALUE (tmp);
TREE_PURPOSE (tmp) = se.expr;
TREE_VALUE (tmp) = align;
TREE_PURPOSE (TREE_CHAIN (tmp)) = init_stmtlist;
TREE_VALUE (TREE_CHAIN (tmp)) = cleanup_stmtlist;
}
else if (n->sym->attr.in_common)
{
gfc_error ("Sorry, !$OMP allocate for COMMON block variable %qs at %L "
"not supported", n->sym->common_block->name,
&n->sym->common_block->where);
break;
}
else
{
gfc_error ("Sorry, !$OMP allocate for variable %qs at %L with SAVE "
"attribute not yet implemented", n->sym->name,
&n->sym->declared_at);
/* FIXME: Remember to handle last_allocator. */
break;
}
gfc_init_block (&tmpblock);
for (f = gfc_sym_get_dummy_args (proc_sym); f; f = f->next)

77
gcc/fortran/trans-openmp.cc
View file

@ -2739,34 +2739,48 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
}
break;
case OMP_LIST_ALLOCATE:
for (; n != NULL; n = n->next)
if (n->sym->attr.referenced)
{
tree t = gfc_trans_omp_variable (n->sym, false);
if (t != error_mark_node)
{
tree node = build_omp_clause (input_location,
OMP_CLAUSE_ALLOCATE);
OMP_CLAUSE_DECL (node) = t;
if (n->u2.allocator)
{
tree allocator_;
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, n->u2.allocator);
allocator_ = gfc_evaluate_now (se.expr, block);
OMP_CLAUSE_ALLOCATE_ALLOCATOR (node) = allocator_;
}
if (n->u.align)
{
tree align_;
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, n->u.align);
align_ = gfc_evaluate_now (se.expr, block);
OMP_CLAUSE_ALLOCATE_ALIGN (node) = align_;
}
omp_clauses = gfc_trans_add_clause (node, omp_clauses);
}
}
{
tree allocator_ = NULL_TREE;
gfc_expr *alloc_expr = NULL;
for (; n != NULL; n = n->next)
if (n->sym->attr.referenced)
{
tree t = gfc_trans_omp_variable (n->sym, false);
if (t != error_mark_node)
{
tree node = build_omp_clause (input_location,
OMP_CLAUSE_ALLOCATE);
OMP_CLAUSE_DECL (node) = t;
if (n->u2.allocator)
{
if (alloc_expr != n->u2.allocator)
{
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, n->u2.allocator);
gfc_add_block_to_block (block, &se.pre);
allocator_ = gfc_evaluate_now (se.expr, block);
gfc_add_block_to_block (block, &se.post);
}
OMP_CLAUSE_ALLOCATE_ALLOCATOR (node) = allocator_;
}
alloc_expr = n->u2.allocator;
if (n->u.align)
{
tree align_;
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, n->u.align);
gcc_assert (CONSTANT_CLASS_P (se.expr)
&& se.pre.head == NULL
&& se.post.head == NULL);
align_ = se.expr;
OMP_CLAUSE_ALLOCATE_ALIGN (node) = align_;
}
omp_clauses = gfc_trans_add_clause (node, omp_clauses);
}
}
else
alloc_expr = n->u2.allocator;
}
break;
case OMP_LIST_LINEAR:
{
@ -7184,11 +7198,14 @@ gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses)
static tree
gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses)
{
tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses, code->loc);
stmtblock_t block;
gfc_start_block (&block);
tree omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
tree stmt = gfc_trans_omp_code (code->block->next, true);
stmt = build2_loc (gfc_get_location (&code->loc), OMP_SINGLE, void_type_node,
stmt, omp_clauses);
return stmt;
gfc_add_expr_to_block (&block, stmt);
return gfc_finish_block (&block);
}
static tree

166
gcc/gimplify.cc
View file

@ -1405,18 +1405,45 @@ gimplify_bind_expr (tree *expr_p, gimple_seq *pre_p)
|| alloc == NULL_TREE
|| !integer_onep (alloc)))
{
tree tmp = build_pointer_type (TREE_TYPE (t));
tree v = create_tmp_var (tmp, get_name (t));
DECL_IGNORED_P (v) = 0;
tmp = remove_attribute ("omp allocate", DECL_ATTRIBUTES (t));
DECL_ATTRIBUTES (v)
= tree_cons (get_identifier ("omp allocate var"),
build_tree_list (NULL_TREE, t), tmp);
tmp = build_fold_indirect_ref (v);
TREE_THIS_NOTRAP (tmp) = 1;
SET_DECL_VALUE_EXPR (t, tmp);
DECL_HAS_VALUE_EXPR_P (t) = 1;
tree sz = TYPE_SIZE_UNIT (TREE_TYPE (t));
/* Fortran might already use a pointer type internally;
use that pointer except for type(C_ptr) and type(C_funptr);
note that normal proc pointers are rejected. */
tree type = TREE_TYPE (t);
tree tmp, v;
if (lang_GNU_Fortran ()
&& POINTER_TYPE_P (type)
&& TREE_TYPE (type) != void_type_node
&& TREE_CODE (TREE_TYPE (type)) != FUNCTION_TYPE)
{
type = TREE_TYPE (type);
v = t;
}
else
{
tmp = build_pointer_type (type);
v = create_tmp_var (tmp, get_name (t));
DECL_IGNORED_P (v) = 0;
DECL_ATTRIBUTES (v)
= tree_cons (get_identifier ("omp allocate var"),
build_tree_list (NULL_TREE, t),
DECL_ATTRIBUTES (t));
tmp = build_fold_indirect_ref (v);
TREE_THIS_NOTRAP (tmp) = 1;
SET_DECL_VALUE_EXPR (t, tmp);
DECL_HAS_VALUE_EXPR_P (t) = 1;
}
tree sz = TYPE_SIZE_UNIT (type);
/* The size to use in Fortran might not match TYPE_SIZE_UNIT;
hence, for some decls, a size variable is saved in the
attributes; use it, if available. */
if (TREE_CHAIN (TREE_VALUE (attr))
&& TREE_CHAIN (TREE_CHAIN (TREE_VALUE (attr)))
&& TREE_PURPOSE (
TREE_CHAIN (TREE_CHAIN (TREE_VALUE (attr)))))
{
sz = TREE_CHAIN (TREE_CHAIN (TREE_VALUE (attr)));
sz = TREE_PURPOSE (sz);
}
if (alloc == NULL_TREE)
alloc = build_zero_cst (ptr_type_node);
if (align == NULL_TREE)
@ -1425,28 +1452,93 @@ gimplify_bind_expr (tree *expr_p, gimple_seq *pre_p)
align = build_int_cst (size_type_node,
MAX (tree_to_uhwi (align),
DECL_ALIGN_UNIT (t)));
location_t loc = DECL_SOURCE_LOCATION (t);
tmp = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC);
tmp = build_call_expr_loc (DECL_SOURCE_LOCATION (t), tmp,
3, align, sz, alloc);
tmp = fold_build2_loc (DECL_SOURCE_LOCATION (t), MODIFY_EXPR,
TREE_TYPE (v), v,
tmp = build_call_expr_loc (loc, tmp, 3, align, sz, alloc);
tmp = fold_build2_loc (loc, MODIFY_EXPR, TREE_TYPE (v), v,
fold_convert (TREE_TYPE (v), tmp));
gcc_assert (BIND_EXPR_BODY (bind_expr) != NULL_TREE
&& (TREE_CODE (BIND_EXPR_BODY (bind_expr))
== STATEMENT_LIST));
tree_stmt_iterator e = tsi_start (BIND_EXPR_BODY (bind_expr));
while (!tsi_end_p (e))
gcc_assert (BIND_EXPR_BODY (bind_expr) != NULL_TREE);
/* Ensure that either TREE_CHAIN (TREE_VALUE (attr) is set
and GOMP_FREE added here or that DECL_HAS_VALUE_EXPR_P (t)
is set, using in a condition much further below. */
gcc_assert (DECL_HAS_VALUE_EXPR_P (t)
|| TREE_CHAIN (TREE_VALUE (attr)));
if (TREE_CHAIN (TREE_VALUE (attr)))
{
if ((TREE_CODE (*e) == DECL_EXPR
&& TREE_OPERAND (*e, 0) == t)
|| (TREE_CODE (*e) == CLEANUP_POINT_EXPR
&& TREE_CODE (TREE_OPERAND (*e, 0)) == DECL_EXPR
&& TREE_OPERAND (TREE_OPERAND (*e, 0), 0) == t))
break;
/* Fortran is special as it does not have properly nest
declarations in blocks. And as there is no
initializer, there is also no expression to look for.
Hence, the FE makes the statement list of the
try-finally block available. We can put the GOMP_alloc
at the top, unless an allocator or size expression
requires to put it afterward; note that the size is
always later in generated code; for strings, no
size expr but still an expr might be available. */
tree sl = TREE_PURPOSE (TREE_CHAIN (TREE_VALUE (attr)));
tree_stmt_iterator e = tsi_start (sl);
tree needle = NULL_TREE;
if (TREE_CHAIN (TREE_CHAIN (TREE_VALUE (attr))))
{
needle = TREE_CHAIN (TREE_CHAIN (TREE_VALUE (attr)));
needle = (TREE_VALUE (needle) ? TREE_VALUE (needle)
: sz);
}
else if (TREE_CHAIN (TREE_CHAIN (TREE_VALUE (attr))))
needle = sz;
else if (DECL_P (alloc) && DECL_ARTIFICIAL (alloc))
needle = alloc;
if (needle != NULL_TREE)
{
while (!tsi_end_p (e))
{
if (*e == needle
|| (TREE_CODE (*e) == MODIFY_EXPR
&& TREE_OPERAND (*e, 0) == needle))
break;
++e;
}
gcc_assert (!tsi_end_p (e));
}
tsi_link_after (&e, tmp, TSI_SAME_STMT);
/* As the cleanup is in BIND_EXPR_BODY, GOMP_free is added
here; for C/C++ it will be added in the 'cleanup'
section after gimplification. But Fortran already has
a try-finally block. */
sl = TREE_VALUE (TREE_CHAIN (TREE_VALUE (attr)));
e = tsi_last (sl);
tmp = builtin_decl_explicit (BUILT_IN_GOMP_FREE);
tmp = build_call_expr_loc (EXPR_LOCATION (*e), tmp, 2, v,
build_zero_cst (ptr_type_node));
tsi_link_after (&e, tmp, TSI_SAME_STMT);
tmp = build_clobber (TREE_TYPE (v), CLOBBER_EOL);
tmp = fold_build2_loc (loc, MODIFY_EXPR, TREE_TYPE (v), v,
fold_convert (TREE_TYPE (v), tmp));
++e;
tsi_link_after (&e, tmp, TSI_SAME_STMT);
}
gcc_assert (!tsi_end_p (e));
tsi_link_before (&e, tmp, TSI_SAME_STMT);
else
{
gcc_assert (TREE_CODE (BIND_EXPR_BODY (bind_expr))
== STATEMENT_LIST);
tree_stmt_iterator e;
e = tsi_start (BIND_EXPR_BODY (bind_expr));
while (!tsi_end_p (e))
{
if ((TREE_CODE (*e) == DECL_EXPR
&& TREE_OPERAND (*e, 0) == t)
|| (TREE_CODE (*e) == CLEANUP_POINT_EXPR
&& (TREE_CODE (TREE_OPERAND (*e, 0))
== DECL_EXPR)
&& (TREE_OPERAND (TREE_OPERAND (*e, 0), 0)
== t)))
break;
++e;
}
gcc_assert (!tsi_end_p (e));
tsi_link_before (&e, tmp, TSI_SAME_STMT);
}
}
}
@ -1539,16 +1631,26 @@ gimplify_bind_expr (tree *expr_p, gimple_seq *pre_p)
&& !is_global_var (t)
&& DECL_CONTEXT (t) == current_function_decl)
{
tree attr;
if (flag_openmp
&& DECL_HAS_VALUE_EXPR_P (t)
&& TREE_USED (t)
&& lookup_attribute ("omp allocate", DECL_ATTRIBUTES (t)))
&& ((attr = lookup_attribute ("omp allocate",
DECL_ATTRIBUTES (t))) != NULL_TREE)
&& TREE_CHAIN (TREE_VALUE (attr)) == NULL_TREE)
{
/* For Fortran, TREE_CHAIN (TREE_VALUE (attr)) is set, which
causes that the GOMP_free call is already added above. */
tree v = TREE_OPERAND (DECL_VALUE_EXPR (t), 0);
tree tmp = builtin_decl_explicit (BUILT_IN_GOMP_FREE);
tmp = build_call_expr_loc (end_locus, tmp, 2,
TREE_OPERAND (DECL_VALUE_EXPR (t), 0),
tmp = build_call_expr_loc (end_locus, tmp, 2, v,
build_zero_cst (ptr_type_node));
gimplify_and_add (tmp, &cleanup);
gimple *clobber_stmt;
tmp = build_clobber (TREE_TYPE (v), CLOBBER_EOL);
clobber_stmt = gimple_build_assign (v, tmp);
gimple_set_location (clobber_stmt, end_locus);
gimplify_seq_add_stmt (&cleanup, clobber_stmt);
}
if (!DECL_HARD_REGISTER (t)
&& !TREE_THIS_VOLATILE (t)

2
gcc/testsuite/c-c++-common/gomp/allocate-14.c
View file

@ -17,7 +17,7 @@ h ()
{
#pragma omp target
#pragma omp parallel
#pragma omp serial
#pragma omp single
{
int var2[5]; /* { dg-error "'allocate' directive for 'var2' inside a target region must specify an 'allocator' clause" } */
#pragma omp allocate(var2)

2
gcc/testsuite/c-c++-common/gomp/allocate-15.c
View file

@ -19,7 +19,7 @@ h ()
{
#pragma omp target
#pragma omp parallel
#pragma omp serial
#pragma omp single
{
int var2[5];
#pragma omp allocate(var2)

2
gcc/testsuite/c-c++-common/gomp/allocate-9.c
View file

@ -20,7 +20,7 @@ typedef enum omp_allocator_handle_t
static int A[5] = {1,2,3,4,5};
int B, C, D;
/* If the following fails bacause of added predefined allocators, please update
/* If the following fails because of added predefined allocators, please update
- c/c-parser.c's c_parser_omp_allocate
- fortran/openmp.cc's is_predefined_allocator
- libgomp/env.c's parse_allocator

75
gcc/testsuite/gfortran.dg/gomp/allocate-10.f90 Normal file
View file

@ -0,0 +1,75 @@
! { dg-additional-options "-Wall -fdump-tree-gimple" }
module m
use iso_c_binding
integer, parameter :: omp_allocator_handle_kind = c_intptr_t
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_null_allocator = 0
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_default_mem_alloc = 1
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_large_cap_mem_alloc = 2
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_const_mem_alloc = 3
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_high_bw_mem_alloc = 4
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_low_lat_mem_alloc = 5
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_cgroup_mem_alloc = 6
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_pteam_mem_alloc = 7
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_thread_mem_alloc = 8
end
! { dg-final { scan-tree-dump-times "__builtin_GOMP_alloc" 3 "gimple" } }
! { dg-final { scan-tree-dump-times "__builtin_GOMP_free" 3 "gimple" } }
subroutine f
use m
implicit none
integer :: n
block
integer :: A(n) ! { dg-warning "Unused variable 'a' declared" }
end block
end
subroutine f2
use m
implicit none
integer :: n ! { dg-note "'n' was declared here" }
block
integer :: A(n) ! { dg-warning "'n' is used uninitialized" }
!$omp allocate(A)
! by matching 'A' above, TREE_USE is set. Hence:
! { dg-final { scan-tree-dump-times "a = __builtin_GOMP_alloc \\(., D\.\[0-9\]+, 0B\\);" 1 "gimple" } }
! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(a, 0B\\);" 1 "gimple" } }
end block
end
subroutine h1()
use m
implicit none
integer(omp_allocator_handle_kind) my_handle ! { dg-note "'my_handle' was declared here" }
integer :: B1(3)
!$omp allocate(B1) allocator(my_handle) ! { dg-warning "31:'my_handle' is used uninitialized" }
B1(1) = 5
! { dg-final { scan-tree-dump-times "b1.\[0-9\]+ = __builtin_GOMP_alloc \\(4, 12, D\.\[0-9\]+\\);" 1 "gimple" } }
! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(b1.\[0-9\]+, 0B\\);" 1 "gimple" } }
end
subroutine h2()
use m
implicit none
integer(omp_allocator_handle_kind) my_handle ! { dg-note "'my_handle' was declared here" }
block
integer :: B2(3)
!$omp allocate(B2) allocator(my_handle) ! { dg-warning "33:'my_handle' is used uninitialized" }
! Similar above; B2 is unused - but in gfortran, the match in 'allocate(B2)' already
! causes TREE_USED = 1
! { dg-final { scan-tree-dump-times "b2.\[0-9\]+ = __builtin_GOMP_alloc \\(4, 12, D\.\[0-9\]+\\);" 1 "gimple" } }
! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(b2.\[0-9\]+, 0B\\);" 1 "gimple" } }
end block
end

33
gcc/testsuite/gfortran.dg/gomp/allocate-11.f90 Normal file
View file

@ -0,0 +1,33 @@
module m
use iso_c_binding
integer, parameter :: omp_allocator_handle_kind = c_intptr_t
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_null_allocator = 0
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_default_mem_alloc = 1
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_large_cap_mem_alloc = 2
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_const_mem_alloc = 3
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_high_bw_mem_alloc = 4
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_low_lat_mem_alloc = 5
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_cgroup_mem_alloc = 6
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_pteam_mem_alloc = 7
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_thread_mem_alloc = 8
end
subroutine f ()
use m
implicit none
integer :: i
!$omp parallel firstprivate(i) allocate(allocator(omp_low_latency_mem_alloc): i)
! { dg-error "Symbol 'omp_low_latency_mem_alloc' at .1. has no IMPLICIT type; did you mean 'omp_low_lat_mem_alloc'\\\?" "" { target *-*-* } .-1 }
! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind at .1." "" { target *-*-* } .-2 }
i = 4
!$omp end parallel
end

24
gcc/testsuite/gfortran.dg/gomp/allocate-12.f90 Normal file
View file

@ -0,0 +1,24 @@
module m
implicit none
contains
subroutine f ()
!$omp declare target
integer :: var ! { dg-error "'allocate' directive for 'var' inside a target region must specify an 'allocator' clause" }
!$omp allocate(var)
var = 5
end
subroutine h ()
!$omp target
!$omp parallel
!$omp single
block
integer :: var2(5) ! { dg-error "'allocate' directive for 'var2' inside a target region must specify an 'allocator' clause" }
!$omp allocate(var2)
var2(1) = 7
end block
!$omp end single
!$omp end parallel
!$omp end target
end
end module

25
gcc/testsuite/gfortran.dg/gomp/allocate-13.f90 Normal file
View file

@ -0,0 +1,25 @@
module m
implicit none
!$omp requires dynamic_allocators
contains
subroutine f ()
!$omp declare target
integer :: var
!$omp allocate(var)
var = 5
end
subroutine h ()
!$omp target
!$omp parallel
!$omp single
block
integer :: var2(5)
!$omp allocate(var2)
var2(1) = 7
end block
!$omp end single
!$omp end parallel
!$omp end target
end
end module

95
gcc/testsuite/gfortran.dg/gomp/allocate-14.f90 Normal file
View file

@ -0,0 +1,95 @@
! { dg-additional-options "-fcoarray=single -fcray-pointer" }
module m
use iso_c_binding
integer, parameter :: omp_allocator_handle_kind = c_intptr_t
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_null_allocator = 0
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_default_mem_alloc = 1
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_large_cap_mem_alloc = 2
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_const_mem_alloc = 3
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_high_bw_mem_alloc = 4
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_low_lat_mem_alloc = 5
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_cgroup_mem_alloc = 6
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_pteam_mem_alloc = 7
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_thread_mem_alloc = 8
end
subroutine coarrays(x)
use m
implicit none
integer :: x[*]
integer, allocatable :: y[:], z(:)[:]
!$omp allocate(x) ! { dg-error "Unexpected dummy argument 'x' as argument at .1. to declarative !.OMP ALLOCATE" }
!$omp allocators allocate(y) ! { dg-error "28:Unexpected coarray 'y' in 'allocate' at .1." }
allocate(y[*])
!$omp allocate(z) ! { dg-error "17:Unexpected coarray 'z' in 'allocate' at .1." }
allocate(z(5)[*])
x = 5
end
integer function f() result(res)
!$omp allocate(f) ! { dg-error "Argument 'f' at .1. to declarative !.OMP ALLOCATE directive must be a variable" }
!$omp allocate(res) ! { dg-error "Unexpected function-result variable 'res' at .1. in declarative !.OMP ALLOCATE" }
res = 5
end
integer function g() result(res)
allocatable :: res
!$omp allocators allocate(g) ! { dg-error "Expected variable list at .1." }
!$omp allocators allocate (res)
allocate(res, source=5)
deallocate(res)
!$omp allocate (res)
allocate(res, source=5)
end
subroutine cray_ptr()
real pointee(10)
pointer (ipt, pointee)
!$omp allocate(pointee) ! { dg-error "Sorry, Cray pointers and pointees such as 'pointee' are not supported with !.OMP ALLOCATE at .1." }
!$omp allocate(ipt) ! { dg-error "Sorry, Cray pointers and pointees such as 'ipt' are not supported with !.OMP ALLOCATE at .1." }
end
subroutine equiv
integer :: A
real :: B(2)
equivalence(A,B)
!$omp allocate (A) ! { dg-error "Sorry, EQUIVALENCE object 'a' not supported with !.OMP ALLOCATE at .1." }
!$omp allocate (B) ! { dg-error "Sorry, EQUIVALENCE object 'b' not supported with !.OMP ALLOCATE at .1." }
end
subroutine common
use m
integer :: a,b,c(5)
common /my/ a,b,c
!$omp allocate(b) allocator(omp_cgroup_mem_alloc) ! { dg-error "'b' at .1. is part of the common block '/my/' and may only be specificed implicitly via the named common block" }
end
subroutine c_and_func_ptrs
use iso_c_binding
implicit none
procedure(), pointer :: p
type(c_ptr) :: cptr
type(c_ptr) :: cfunptr
!$omp allocate(cptr) ! OK
!$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

38
gcc/testsuite/gfortran.dg/gomp/allocate-15.f90 Normal file
View file

@ -0,0 +1,38 @@
module m
use iso_c_binding
integer, parameter :: omp_allocator_handle_kind = c_intptr_t
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_null_allocator = 0
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_default_mem_alloc = 1
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_large_cap_mem_alloc = 2
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_const_mem_alloc = 3
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_high_bw_mem_alloc = 4
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_low_lat_mem_alloc = 5
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_cgroup_mem_alloc = 6
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_pteam_mem_alloc = 7
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_thread_mem_alloc = 8
end
subroutine common
use m
integer :: a,b,c(5)
common /my/ a,b,c ! { dg-error "Sorry, !.OMP allocate for COMMON block variable 'my' at .1. not supported" }
!$omp allocate(/my/) allocator(omp_cgroup_mem_alloc)
end
integer function allocators() result(res)
use m
integer, save :: a(5) = [1,2,3,4,5] ! { dg-error "Sorry, !.OMP allocate for variable 'a' at .1. with SAVE attribute not yet implemented" }
!$omp allocate(a) allocator(omp_high_bw_mem_alloc)
res = a(4)
end

4
gcc/testsuite/gfortran.dg/gomp/allocate-4.f90
View file

@ -33,13 +33,13 @@ integer(kind=omp_allocator_handle_kind), intent(in) :: my_alloc
!stack variables:
integer :: a,b,c(n),d(5),e(2)
!$omp allocate(a) ! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" }
!$omp allocate(a)
!$omp allocate ( b , c ) align ( 32) allocator (my_alloc)
!$omp allocate (d) align( 128 )
!$omp allocate( e ) allocator( omp_high_bw_mem_alloc )
!saved vars
integer, save :: k,l,m(5),r(2)
integer, save :: k,l,m(5),r(2) ! { dg-error "Sorry, !.OMP allocate for variable 'k' at .1. with SAVE attribute not yet implemented" }
!$omp allocate(k) align(16) , allocator (omp_large_cap_mem_alloc)
!$omp allocate ( l ) allocator (omp_large_cap_mem_alloc) , align ( 32)
!$omp allocate (m) align( 128 ),allocator( omp_high_bw_mem_alloc )

10
gcc/testsuite/gfortran.dg/gomp/allocate-7.f90
View file

@ -47,7 +47,6 @@ integer, pointer :: ptr
integer, parameter :: prm=5
!$omp allocate(prm) align(64) ! { dg-error "Argument 'prm' at .1. to declarative !.OMP ALLOCATE directive must be a variable" }
! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
!$omp allocate(used) allocator(omp_pteam_mem_alloc) ! { dg-error "Argument 'used' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" }
!$omp allocate(n) allocator(omp_pteam_mem_alloc) ! { dg-error "Unexpected dummy argument 'n' as argument at .1. to declarative !.OMP ALLOCATE" }
@ -59,7 +58,6 @@ contains
subroutine inner
!$omp allocate(a) allocator(omp_pteam_mem_alloc) ! { dg-error "Argument 'a' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" }
! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
end
end
@ -74,7 +72,6 @@ common /com4/ y,z
allocatable :: q
pointer :: b
!$omp allocate (c, d) allocator (omp_pteam_mem_alloc)
! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
!$omp allocate (/com4/) allocator (omp_pteam_mem_alloc)
!$omp allocate (c) allocator (omp_pteam_mem_alloc) ! { dg-error "Duplicated variable 'c' in !.OMP ALLOCATE" }
!$omp allocate (/com4/) allocator (omp_pteam_mem_alloc) ! { dg-error "Duplicated common block '/com4/' in !.OMP ALLOCATE" }
@ -86,7 +83,6 @@ end
subroutine four(n)
integer :: qq, rr, ss, tt, uu, vv,n
!$omp allocate (qq) align(3+n) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
!$omp allocate (rr) align([4]) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
!$omp allocate (ss) align([4]) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
!$omp allocate (tt) align(32.0) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
@ -99,7 +95,6 @@ subroutine five(n,my_alloc)
integer :: qq, rr, ss, tt, uu, vv,n
integer(omp_allocator_handle_kind) :: my_alloc
!$omp allocate (qq) allocator(3.0) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
!$omp allocate (rr) allocator(3_2) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
!$omp allocate (tt) allocator(my_alloc) ! OK
@ -113,7 +108,6 @@ subroutine five_SaveAll(n,my_alloc)
integer :: qq, rr, ss, tt, uu, vv,n
integer(omp_allocator_handle_kind) :: my_alloc
!$omp allocate (qq) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAVE attribute" }
! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
!$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAVE attribute" }
!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'ss' at .2. has the SAVE attribute" }
!$omp allocate (tt) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has the SAVE attribute" }
@ -127,7 +121,6 @@ subroutine five_Save(n,my_alloc)
integer, save :: qq, rr, ss, tt, uu, vv
integer(omp_allocator_handle_kind) :: my_alloc
!$omp allocate (qq) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAVE attribute" }
! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
!$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAVE attribute" }
!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'ss' at .2. has the SAVE attribute" }
!$omp allocate (tt) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has the SAVE attribute" }
@ -139,7 +132,6 @@ module five_Module
integer, save :: qq, rr, ss, tt, uu, vv,n
integer(omp_allocator_handle_kind) :: my_alloc
!$omp allocate (qq) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAVE attribute" }
! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
!$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAVE attribute" }
!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'ss' at .2. has the SAVE attribute" }
!$omp allocate (tt) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has the SAVE attribute" }
@ -151,7 +143,6 @@ program five_program
integer, save :: qq, rr, ss, tt, uu, vv,n
integer(omp_allocator_handle_kind) :: my_alloc
!$omp allocate (qq) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAVE attribute" }
! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
!$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAVE attribute" }
!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'ss' at .2. has the SAVE attribute" }
!$omp allocate (tt) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has the SAVE attribute" }
@ -170,7 +161,6 @@ subroutine six(n,my_alloc)
integer(omp_allocator_handle_kind) :: my_alloc
!$omp allocate (/com6qq/) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item '/com6qq/' at .2. has the SAVE attribute" }
! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
!$omp allocate (/com6rr/) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item '/com6rr/' at .2. has the SAVE attribute" }
!$omp allocate (/com6ss/) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item '/com6ss/' at .2. has the SAVE attribute" }
!$omp allocate (/com6tt/) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item '/com6tt/' at .2. has the SAVE attribute" }

29
gcc/testsuite/gfortran.dg/gomp/allocate-8.f90 Normal file
View file

@ -0,0 +1,29 @@
! { dg-additional-options "-fdump-tree-original" }
module m
use iso_c_binding
!use omp_lib, only: omp_allocator_handle_kind
implicit none
integer, parameter :: omp_allocator_handle_kind = c_intptr_t
integer :: a = 0, b = 42, c = 0
contains
integer(omp_allocator_handle_kind) function get_alloc()
allocatable :: get_alloc
get_alloc = 2_omp_allocator_handle_kind
end
subroutine foo ()
!$omp scope private (a) firstprivate (b) reduction (+: c) allocate ( get_alloc() : a , b , c)
if (b /= 42) &
error stop
a = 36
b = 15
c = c + 1
!$omp end scope
end
end
! { dg-final { scan-tree-dump "omp scope private\\(a\\) firstprivate\\(b\\) reduction\\(\\+:c\\) allocate\\(allocator\\(D\\.\[0-9\]+\\):a\\) allocate\\(allocator\\(D\\.\[0-9\]+\\):b\\) allocate\\(allocator\\(D\\.\[0-9\]+\\):c\\)" "original" } }
! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ = get_alloc \\(\\);\[\n\r\]+ *D\\.\[0-9\]+ = \\*D\\.\[0-9\]+;\[\n\r\]+ *__builtin_free \\(\\(void \\*\\) D\\.\[0-9\]+\\);" 1 "original" } }

112
gcc/testsuite/gfortran.dg/gomp/allocate-9.f90 Normal file
View file

@ -0,0 +1,112 @@
module m
use iso_c_binding
integer, parameter :: omp_allocator_handle_kind = c_intptr_t
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_null_allocator = 0
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_default_mem_alloc = 1
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_large_cap_mem_alloc = 2
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_const_mem_alloc = 3
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_high_bw_mem_alloc = 4
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_low_lat_mem_alloc = 5
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_cgroup_mem_alloc = 6
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_pteam_mem_alloc = 7
integer (kind=omp_allocator_handle_kind), &
parameter :: omp_thread_mem_alloc = 8
end
module m2
use m
implicit none
integer :: A(5) = [1,2,3,4,5], A2, A3, A4, A5
integer :: B, C, D
! If the following fails because of added predefined allocators, please update
! - c/c-parser.c's c_parser_omp_allocate
! - fortran/openmp.cc's is_predefined_allocator
! - libgomp/env.c's parse_allocator
! - libgomp/libgomp.texi (document the new values - multiple locations)
! + ensure that the memory-spaces are also up to date.
!$omp allocate(A) align(32) allocator(9_omp_allocator_handle_kind) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'a' at .2. has the SAVE attribute" }
! typo in allocator name:
!$omp allocate(A2) allocator(omp_low_latency_mem_alloc) ! { dg-error "Symbol 'omp_low_latency_mem_alloc' at .1. has no IMPLICIT type; did you mean 'omp_low_lat_mem_alloc'\\?" }
! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'a2' at .2. has the SAVE attribute" "" { target *-*-* } .-1 }
! align be const multiple of 2
!$omp allocate(A3) align(31) allocator(omp_default_mem_alloc) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
! allocator missing (required as A is static)
!$omp allocate(A4) align(32) ! { dg-error "An ALLOCATOR clause is required as the list item 'a4' at .1. has the SAVE attribute" }
! "expression in the clause must be a constant expression that evaluates to one of the
! predefined memory allocator values -> omp_low_lat_mem_alloc"
!$omp allocate(B) allocator(omp_high_bw_mem_alloc+1_omp_allocator_handle_kind) align(32) ! OK: omp_low_lat_mem_alloc
!$omp allocate(C) allocator(2_omp_allocator_handle_kind) ! OK: omp_large_cap_mem_alloc
!$omp allocate(A5) align(32) allocator(omp_null_allocator) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'a5' at .2. has the SAVE attribute" }
!$omp allocate(C) align(32) allocator(omp_large_cap_mem_alloc) ! { dg-error "Duplicated variable 'c' in !.OMP ALLOCATE at .1." }
contains
integer function f()
!$omp allocate(D) align(32) allocator(omp_large_cap_mem_alloc) ! { dg-error "Argument 'd' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" }
f = A(1)
end
integer function g()
integer :: a2, b2
!$omp allocate(a2)
!$omp allocate(a2) ! { dg-error "Duplicated variable 'a2' in !.OMP ALLOCATE at .1." }
a2=1; b2=2
block
integer :: c2
!$omp allocate(c2, b2) ! { dg-error "Argument 'b2' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" }
c2 = 3
g = c2+a2+b2
end block
end
integer function h(q)
integer :: q
!$omp allocate(q) ! { dg-error "Unexpected dummy argument 'q' as argument at .1. to declarative !.OMP ALLOCATE" }
h = q
end
integer function k ()
integer, save :: var3 = 8
!$omp allocate(var3) allocator(-1_omp_allocator_handle_kind) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'var3' at .2. has the SAVE attribute" }
k = var3
end
end module
subroutine foo
integer :: a, b
integer :: c, d,h
!$omp allocate(a,b)
b = 1; d = 5
contains
subroutine internal
integer :: e,f
!$omp allocate(c,d)
! { dg-error "Argument 'c' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" "" { target *-*-* } .-1 }
! { dg-error "Argument 'd' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" "" { target *-*-* } .-2 }
!$omp allocate(e)
a = 1; c = 2; e = 4
block
!$omp allocate(f) ! { dg-error "Argument 'f' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" }
!$omp allocate(h) ! { dg-error "Argument 'h' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" }
end block
end
end

4
libgomp/libgomp.texi
View file

@ -225,7 +225,7 @@ 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, only stack variables
@item @code{allocate} directive @tab P @tab Only C and Fortran, only stack 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
@ -297,7 +297,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 only stack variables)
@tab Only C and Fortran (and only stack 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

87
libgomp/testsuite/libgomp.fortran/allocate-5.f90 Normal file
View file

@ -0,0 +1,87 @@
! { dg-additional-options "-fdump-tree-gimple" }
! { dg-final { scan-tree-dump-times "__builtin_GOMP_alloc \\(" 5 "gimple" } }
! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(" 5 "gimple" } }
module m
use omp_lib
use iso_c_binding
implicit none (type, external)
integer(c_intptr_t) :: intptr
contains
integer function one ()
integer :: sum, i
!$omp allocate(sum)
! { dg-final { scan-tree-dump-times "sum\\.\[0-9\]+ = __builtin_GOMP_alloc \\(4, 4, 0B\\);" 1 "gimple" } }
! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(sum\\.\[0-9\]+, 0B\\);" 1 "gimple" } }
! NOTE: Initializer cannot be omp_init_allocator - as 'A' is
! in the same scope and the auto-omp_free comes later than
! any omp_destroy_allocator.
integer(omp_allocator_handle_kind) :: my_allocator = omp_low_lat_mem_alloc
integer :: n = 25
sum = 0
block
type(omp_alloctrait) :: traits(1) = [ omp_alloctrait(omp_atk_alignment, 64) ]
integer :: A(n)
!$omp allocate(A) align(128) allocator(my_allocator)
! { dg-final { scan-tree-dump-times "a = __builtin_GOMP_alloc \\(128, D\\.\[0-9\]+, D\\.\[0-9\]+\\);" 1 "gimple" } }
! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(a, 0B\\);" 1 "gimple" } }
if (mod (transfer(loc(A), intptr), 128_c_intptr_t) /= 0) &
stop 2
do i = 1, n
A(i) = i
end do
my_allocator = omp_init_allocator(omp_low_lat_mem_space,1,traits)
block
integer B(n)
integer C(5)
!$omp allocate(B,C) allocator(my_allocator)
! { dg-final { scan-tree-dump-times "b = __builtin_GOMP_alloc \\(\[0-9\]+, D\\.\[0-9\]+, D\\.\[0-9\]+\\);" 1 "gimple" } }
! { dg-final { scan-tree-dump-times "c\\.\[0-9\]+ = __builtin_GOMP_alloc \\(\[0-9\]+, 20, D\\.\[0-9\]+\\);" 1 "gimple" } }
! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(b, 0B\\);" 1 "gimple" } }
! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(c\\.\[0-9\]+, 0B\\);" 1 "gimple" } }
integer :: D(5)
!$omp allocate(D) align(256)
! { dg-final { scan-tree-dump-times "d\\.\[0-9\]+ = __builtin_GOMP_alloc \\(256, 20, 0B\\);" 1 "gimple" } }
! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(d\\.\[0-9\]+, 0B\\);" 1 "gimple" } }
B = 0
C = [1,2,3,4,5]
D = [11,22,33,44,55]
if (mod (transfer(loc(B), intptr), 64_c_intptr_t) /= 0) &
stop 3
if (mod (transfer(loc(C), intptr), 64_c_intptr_t) /= 0) &
stop 4
if (mod (transfer(loc(D), intptr), 256_c_intptr_t) /= 0) &
stop 5
do i = 1, 5
if (C(i) /= i) &
stop 6
if (D(i) /= i + 10*i) &
stop 7
end do
do i = 1, n
if (B(i) /= 0) &
stop 9
sum = sum + A(i)+B(i)+C(mod(i,5)+1)+D(mod(i,5)+1)
end do
end block
call omp_destroy_allocator (my_allocator)
end block
one = sum
end
end module
use m
if (one () /= 1225) &
stop 1
end

123
libgomp/testsuite/libgomp.fortran/allocate-6.f90 Normal file
View file

@ -0,0 +1,123 @@
module m
use iso_c_binding
use omp_lib
implicit none (type, external)
integer(c_intptr_t) :: intptr
! { dg-final { scan-tree-dump-not "__builtin_stack_save" "gimple" } }
! { dg-final { scan-tree-dump-not "__builtin_alloca" "gimple" } }
! { dg-final { scan-tree-dump-not "__builtin_stack_restore" "gimple" } }
! { dg-final { scan-tree-dump-times "__builtin_GOMP_alloc \\(" 5 "gimple" } }
! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(" 5 "gimple" } }
contains
subroutine one ()
integer :: result, n, i
result = 0
n = 3
!$omp target map(tofrom: result) firstprivate(n)
block
integer :: var, var2(n)
!$omp allocate(var,var2) align(128) allocator(omp_low_lat_mem_alloc)
var = 5
! { dg-final { scan-tree-dump-times "var\\.\[0-9\]+ = __builtin_GOMP_alloc \\(128, 4, 5\\);" 1 "gimple" } } */
! { dg-final { scan-tree-dump-times "var2\\.\[0-9\]+ = __builtin_GOMP_alloc \\(128, D\\.\[0-9\]+, 5\\);" 1 "gimple" } } */
! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(var\\.\[0-9\]+, 0B\\);" 1 "gimple" } } */
! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(var2\\.\[0-9\]+, 0B\\);" 1 "gimple" } } */
if (mod(transfer(loc(var), intptr), 128_c_intptr_t) /= 0) &
stop 1
if (mod(transfer(loc(var2), intptr), 128_c_intptr_t) /= 0) &
stop 2
if (var /= 5) &
stop 3
!$omp parallel do
do i = 1, n
var2(i) = (i+32);
end do
!$omp parallel loop reduction(+:result)
do i = 1, n
result = result + var + var2(i)
end do
end block
if (result /= (3*5 + 33 + 34 + 35)) &
stop 4
end
subroutine two ()
type st
integer :: a, b
end type
integer :: scalar, array(5), i
type(st) s
!$omp allocate(scalar, array, s)
! { dg-final { scan-tree-dump-times "scalar\\.\[0-9\]+ = __builtin_GOMP_alloc \\(4, 4, 0B\\);" 1 "gimple" } }
! { dg-final { scan-tree-dump-times "array\\.\[0-9\]+ = __builtin_GOMP_alloc \\(4, 20, 0B\\);" 1 "gimple" } }
! { dg-final { scan-tree-dump-times "s\\.\[0-9\]+ = __builtin_GOMP_alloc \\(4, 8, 0B\\);" 1 "gimple" } }
! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(scalar\\.\[0-9\]+, 0B\\);" 1 "gimple" } }
! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(array\\.\[0-9\]+, 0B\\);" 1 "gimple" } }
! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(s\\.\[0-9\]+, 0B\\);" 1 "gimple" } }
scalar = 44
array = [1,2,3,4,5]
s = st(a=11, b=56)
!$omp parallel firstprivate(scalar) firstprivate(array) firstprivate(s)
if (scalar /= 44) &
stop 5
scalar = 33;
if (any (array /= [1,2,3,4,5])) &
stop 6
array = [10,20,30,40,50]
if (s%a /= 11 .or. s%b /= 56) &
stop 7
s%a = 74
s%b = 674
!$omp end parallel
if (scalar /= 44) &
stop 8
if (any (array /= [1,2,3,4,5])) &
stop 9
if (s%a /= 11 .or. s%b /= 56) &
stop 10
!$omp target defaultmap(firstprivate : scalar) defaultmap(none : aggregate) defaultmap(none : pointer)
if (scalar /= 44) &
stop 11
scalar = 33;
!$omp end target
if (scalar /= 44) &
stop 12
!$omp target defaultmap(none : scalar) defaultmap(firstprivate : aggregate) defaultmap(none : pointer) private(i)
if (any (array /= [1,2,3,4,5])) &
stop 13
do i = 1, 5
array(i) = 10*i
end do
!$omp end target
if (any(array /= [1,2,3,4,5])) &
stop 13
!$omp target defaultmap(none : scalar) defaultmap(firstprivate : aggregate) defaultmap(none : pointer)
if (s%a /= 11 .or. s%b /= 56) &
stop 14
s%a = 74
s%b = 674
!$omp end target
if (s%a /= 11 .or. s%b /= 56) &
stop 15
end
end module
use m
call one ()
call two ()
end

342
libgomp/testsuite/libgomp.fortran/allocate-7.f90 Normal file
View file

@ -0,0 +1,342 @@
! { dg-additional-options "-fdump-tree-omplower" }
! For the 4 vars in omp_parallel, 4 in omp_target and 2 in no_alloc2_func.
! { dg-final { scan-tree-dump-times "__builtin_GOMP_alloc \\(" 10 "omplower" } }
! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(" 10 "omplower" } }
module m
use iso_c_binding
use omp_lib
implicit none (type, external)
integer(c_intptr_t) :: intptr
contains
subroutine check_int (x, y)
integer :: x, y
value :: y
if (x /= y) &
stop 1
end
subroutine check_ptr (x, y)
type(c_ptr) :: x
integer(c_intptr_t), value :: y
if (transfer(x,intptr) /= y) &
stop 2
end
integer function no_alloc_func () result(res)
! There is no __builtin_GOMP_alloc / __builtin_GOMP_free as
! allocator == omp_default_mem_alloc (known at compile time.
integer :: no_alloc
!$omp allocate(no_alloc) allocator(omp_default_mem_alloc)
no_alloc = 7
res = no_alloc
end
integer function no_alloc2_func() result(res)
! If no_alloc2 were TREE_UNUSED, there would be no
! __builtin_GOMP_alloc / __builtin_GOMP_free
! However, as the parser already marks no_alloc2
! and is_alloc2 as used, the tree is generated for both vars.
integer :: no_alloc2, is_alloc2
!$omp allocate(no_alloc2, is_alloc2)
is_alloc2 = 7
res = is_alloc2
end
subroutine omp_parallel ()
integer :: i, n, iii, jjj(5)
type(c_ptr) :: ptr
!$omp allocate(iii, jjj, ptr)
n = 6
iii = 5
ptr = transfer (int(z'1234', c_intptr_t), ptr)
block
integer :: kkk(n)
!$omp allocate(kkk)
do i = 1, 5
jjj(i) = 3*i
end do
do i = 1, 6
kkk(i) = 7*i
end do
!$omp parallel default(none) firstprivate(iii, jjj, kkk, ptr) if(.false.)
if (iii /= 5) &
stop 3
iii = 7
call check_int (iii, 7)
do i = 1, 5
if (jjj(i) /= 3*i) &
stop 4
end do
do i = 1, 6
if (kkk(i) /= 7*i) &
stop 5
end do
do i = 1, 5
jjj(i) = 4*i
end do
do i = 1, 6
kkk(i) = 8*i
end do
do i = 1, 5
call check_int (jjj(i), 4*i)
end do
do i = 1, 6
call check_int (kkk(i), 8*i)
end do
if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) &
stop 6
ptr = transfer (int(z'abcd', c_intptr_t), ptr)
if (transfer (ptr, intptr) /= int(z'abcd', c_intptr_t)) &
stop 7
call check_ptr (ptr, int(z'abcd', c_intptr_t))
!$omp end parallel
if (iii /= 5) &
stop 8
call check_int (iii, 5)
do i = 1, 5
if (jjj(i) /= 3*i) &
stop 9
call check_int (jjj(i), 3*i)
end do
do i = 1, 6
if (kkk(i) /= 7*i) &
stop 10
call check_int (kkk(i), 7*i)
end do
if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) &
stop 11
call check_ptr (ptr, int(z'1234', c_intptr_t))
!$omp parallel default(firstprivate) if(.false.)
if (iii /= 5) &
stop 12
iii = 7
call check_int (iii, 7)
do i = 1, 5
if (jjj(i) /= 3*i) &
stop 13
end do
do i = 1, 6
if (kkk(i) /= 7*i) &
stop 14
end do
do i = 1, 5
jjj(i) = 4*i
end do
do i = 1, 6
kkk(i) = 8*i
end do
do i = 1, 5
call check_int (jjj(i), 4*i)
end do
do i = 1, 6
call check_int (kkk(i), 8*i)
end do
if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) &
stop 15
ptr = transfer (int (z'abcd', c_intptr_t), ptr)
if (transfer (ptr, intptr) /= int(z'abcd', c_intptr_t)) &
stop 16
call check_ptr (ptr, int (z'abcd', c_intptr_t))
!$omp end parallel
if (iii /= 5) &
stop 17
call check_int (iii, 5)
do i = 1, 5
if (jjj(i) /= 3*i) &
stop 18
call check_int (jjj(i), 3*i)
end do
do i = 1, 6
if (kkk(i) /= 7*i) &
stop 19
call check_int (kkk(i), 7*i)
end do
if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) &
stop 20
call check_ptr (ptr, int (z'1234', c_intptr_t))
end block
end
subroutine omp_target ()
integer :: i, n, iii, jjj(5)
type(c_ptr) :: ptr
!$omp allocate(iii, jjj, ptr)
n = 6
iii = 5
ptr = transfer (int (z'1234', c_intptr_t), ptr)
block
integer :: kkk(n)
!$omp allocate(kkk)
do i = 1, 5
jjj(i) = 3*i
end do
do i = 1, 6
kkk(i) = 7*i
end do
!$omp target defaultmap(none) firstprivate(iii, jjj, kkk, ptr) private(i)
if (iii /= 5) &
stop 21
iii = 7
call check_int (iii, 7)
do i = 1, 5
if (jjj(i) /= 3*i) &
stop 22
end do
do i = 1, 6
if (kkk(i) /= 7*i) &
stop 23
end do
do i = 1, 5
jjj(i) = 4*i
end do
do i = 1, 6
kkk(i) = 8*i
end do
do i = 1, 5
call check_int (jjj(i), 4*i)
end do
do i = 1, 6
call check_int (kkk(i), 8*i)
end do
if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) &
stop 24
ptr = transfer (int (z'abcd', c_intptr_t), ptr)
if (transfer (ptr, intptr) /= int(z'abcd', c_intptr_t)) &
stop 25
call check_ptr (ptr, int (z'abcd', c_intptr_t))
!$omp end target
if (iii /= 5) &
stop 26
call check_int (iii, 5)
do i = 1, 5
if (jjj(i) /= 3*i) &
stop 27
call check_int (jjj(i), 3*i)
end do
do i = 1, 6
if (kkk(i) /= 7*i) &
stop 28
call check_int (kkk(i), 7*i)
end do
if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) &
stop 29
call check_ptr (ptr, int (z'1234', c_intptr_t))
!$omp target defaultmap(firstprivate)
if (iii /= 5) &
stop 30
iii = 7
call check_int (iii, 7)
do i = 1, 5
if (jjj(i) /= 3*i) &
stop 31
end do
do i = 1, 6
if (kkk(i) /= 7*i) &
stop 32
end do
do i = 1, 5
jjj(i) = 4*i
end do
do i = 1, 6
kkk(i) = 8*i
end do
do i = 1, 5
call check_int (jjj(i), 4*i)
end do
do i = 1, 6
call check_int (kkk(i), 8*i)
end do
if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) &
stop 33
ptr = transfer (int (z'abcd', c_intptr_t), ptr)
if (transfer (ptr, intptr) /= int(z'abcd', c_intptr_t)) &
stop 34
call check_ptr (ptr, int (z'abcd', c_intptr_t))
!$omp end target
if (iii /= 5) &
stop 35
call check_int (iii, 5)
do i = 1, 5
if (jjj(i) /= 3*i) &
stop 36
call check_int (jjj(i), 3*i)
end do
do i = 1, 6
if (kkk(i) /= 7*i) &
stop 37
call check_int (kkk(i), 7*i)
end do
if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) &
stop 38
call check_ptr (ptr, int (z'1234', c_intptr_t))
!$omp target defaultmap(tofrom)
if (iii /= 5) &
stop 39
iii = 7
call check_int (iii, 7)
do i = 1, 5
if (jjj(i) /= 3*i) &
stop 40
end do
do i = 1, 6
if (kkk(i) /= 7*i) &
stop 41
end do
do i = 1, 5
jjj(i) = 4*i
end do
do i = 1, 6
kkk(i) = 8*i
end do
do i = 1, 5
call check_int (jjj(i), 4*i)
end do
do i = 1, 6
call check_int (kkk(i), 8*i)
end do
if (transfer (ptr, intptr) /= int(z'1234', c_intptr_t)) &
stop 42
ptr = transfer (int(z'abcd',c_intptr_t), ptr)
if (transfer (ptr, intptr) /= int(z'abcd', c_intptr_t)) &
stop 43
call check_ptr (ptr, int (z'abcd', c_intptr_t))
!$omp end target
if (iii /= 7) &
stop 44
call check_int (iii, 7)
do i = 1, 5
if (jjj(i) /= 4*i) &
stop 45
call check_int (jjj(i), 4*i)
end do
do i = 1, 6
if (kkk(i) /= 8*i) &
stop 46
call check_int (kkk(i), 8*i)
end do
if (transfer (ptr, intptr) /= int(z'abcd', c_intptr_t)) &
stop 47
call check_ptr (ptr, int (z'abcd', c_intptr_t))
end block
end
end module
use m
call omp_parallel ()
call omp_target ()
end

99
libgomp/testsuite/libgomp.fortran/allocate-8.f90 Normal file
View file

@ -0,0 +1,99 @@
module m
use omp_lib
implicit none
!!$omp requires dynamic_allocators
integer :: final_count
type t
integer :: i = 0
integer, allocatable :: A(:,:)
contains
final :: count_finalization
end type t
contains
elemental impure subroutine count_finalization(self)
type(t), intent(in) :: self
final_count = final_count + 1
end
subroutine test(allocator)
integer(omp_allocator_handle_kind), optional, value :: allocator
call zero_size(allocator)
call finalization_test(allocator)
end subroutine test
subroutine finalization_test(allocator)
integer(omp_allocator_handle_kind), optional, value :: allocator
integer :: n = 5
final_count = 0;
block
type(t) :: A
! !$omp allocate(A) allocator(allocator)
A%i = 1
end block
if (final_count /= 1) &
stop 10
final_count = 0;
block
type(t) :: B(7)
!$omp allocate(B) allocator(allocator)
B(1)%i = 1
end block
if (final_count /= 7) stop 10
final_count = 0;
block
type(t) :: C(n)
! !$omp allocate(C) allocator(allocator)
C(1)%i = 1
end block
if (final_count /= 5) stop 10
final_count = 0;
block
type(t) :: D(0)
! !$omp allocate(D) allocator(allocator)
D(1:0)%i = 1
end block
if (final_count /= 0) stop 10
end subroutine
subroutine zero_size(allocator)
integer(omp_allocator_handle_kind), optional, value :: allocator
integer :: n
n = -3
block
integer :: A(n)
character(len=n) :: B
! !$omp allocate(A,b) allocator(allocator)
if (size(A) /= 0 .or. len(b) /= 0) &
stop 1
B(1:len(b)) ='A'
end block
!!$omp target
block
integer :: A(n)
character(len=n) :: B
! !$omp allocate(A,b) allocator(allocator)
if (size(A) /= 0 .or. len(b) /= 0) &
stop 2
B(1:len(b)) ='A'
end block
end
end module
use m
call test()
call test(omp_default_mem_alloc)
call test(omp_large_cap_mem_alloc)
call test(omp_high_bw_mem_alloc)
call test(omp_low_lat_mem_alloc)
call test(omp_cgroup_mem_alloc)
end