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;
bool free_mem_traits_space)
{
gfc_omp_namelist *n;
+ gfc_expr *last_allocator = NULL;
for (; name; name = n)
{
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)
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;
}
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;
/* 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)
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 "
&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",
"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)
{
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))
"%<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
{
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)
&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;
#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"
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)
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),
#include "gimplify.h"
#include "omp-general.h"
#include "attr-fnspec.h"
+#include "tree-iterator.h"
#define MAX_LABEL_VALUE 99999
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)
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)
}
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:
{
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
|| 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)
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);
+ }
}
}
&& !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)
{
#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)
{
#pragma omp target
#pragma omp parallel
- #pragma omp serial
+ #pragma omp single
{
int var2[5];
#pragma omp allocate(var2)
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
--- /dev/null
+! { 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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+! { 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
--- /dev/null
+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
+
+
!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 )
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" }
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
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" }
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" }
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
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" }
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" }
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" }
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" }
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" }
--- /dev/null
+! { 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" } }
+
--- /dev/null
+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
@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
@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
--- /dev/null
+! { 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
--- /dev/null
+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
--- /dev/null
+! { 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
--- /dev/null
+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
projects / thirdparty / gcc.git / commitdiff
