+2023-10-26 Tobias Burnus <tobias@codesourcery.com>
+
+ Backported from master:
+ 2023-10-14 Tobias Burnus <tobias@codesourcery.com>
+
+ * gimplify.cc (gimplify_bind_expr): Handle Fortran's
+ 'omp allocate' for stack variables.
+
2023-10-26 Tobias Burnus <tobias@codesourcery.com>
Chung-Lin Tang <cltang@codesourcery.com>
+2023-10-26 Tobias Burnus <tobias@codesourcery.com>
+
+ Backported from master:
+ 2023-10-14 Tobias Burnus <tobias@codesourcery.com>
+
+ * 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.
+
2023-10-26 Tobias Burnus <tobias@codesourcery.com>
Backported from master:
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;
|| list == OMP_LIST_FROM);
bool free_align = (list == OMP_LIST_ALLOCATE);
gfc_omp_namelist *n;
+ gfc_expr *last_allocator = NULL;
for (; name; name = n)
{
else if (free_mapper && name->u2.udm)
free (name->u2.udm);
else if (free_align)
- 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_mapper && name->u2.udr)
{
if (name->u2.udr->combiner)
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
n_null = n;
continue;
}
+ if (n->sym->attr.codimension)
+ gfc_error ("Unexpected coarray %qs in %<allocate%> at %L",
+ n->sym->name, &n->where);
for (a = code->block->next->ext.alloc.list; a; a = a->next)
if (a->expr->expr_type == EXPR_VARIABLE
&& a->expr->symtree->n.sym == n->sym)
&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,
+ {
+ 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)
- {
- tree allocator_;
- if (n->u2.allocator->expr_type == EXPR_VARIABLE)
- {
- allocator_
- = gfc_trans_omp_variable (n->u2.allocator->symtree->n.sym,
- false);
+ OMP_CLAUSE_DECL (node) = t;
+ if (n->u2.allocator)
+ {
+ if (alloc_expr != n->u2.allocator
+ && n->u2.allocator->expr_type == EXPR_VARIABLE)
+ {
+ allocator_
+ = gfc_trans_omp_variable (n->u2.allocator->symtree->n.sym,
+ false);
if (POINTER_TYPE_P (TREE_TYPE (allocator_)))
{
allocator_ = build_fold_indirect_ref (allocator_);
allocator_ = gfc_evaluate_now (allocator_, block);
}
- }
- else
- {
- 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);
+ }
+ else 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);
- }
- }
+ }
+ 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)
+2023-10-26 Tobias Burnus <tobias@codesourcery.com>
+
+ Backported from master:
+ 2023-10-14 Tobias Burnus <tobias@codesourcery.com>
+
+ * 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.
+
2023-10-26 Tobias Burnus <tobias@codesourcery.com>
Chung-Lin Tang <cltang@codesourcery.com>
{
#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
+2023-10-26 Tobias Burnus <tobias@codesourcery.com>
+
+ Backported from master:
+ 2023-10-14 Tobias Burnus <tobias@codesourcery.com>
+
+ * libgomp.texi (OpenMP Impl. Status): Mention that Fortran now
+ supports the allocate directive for stack variables.
+ * testsuite/libgomp.fortran/allocate-5a.f90: Renamed from
+ testsuite/libgomp.fortran/allocate-5.f90.
+ * 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.
+
2023-10-26 Tobias Burnus <tobias@codesourcery.com>
Chung-Lin Tang <cltang@codesourcery.com>
@item Predefined memory spaces, memory allocators, allocator traits
@tab Y @tab Some are only stubs
@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
-! { dg-do compile }
+! { dg-additional-options "-fdump-tree-gimple" }
-module test
- integer, allocatable :: mvar1
- integer, allocatable :: mvar2
- integer, allocatable :: mvar3
-end module
-
-subroutine foo(x, y)
- use omp_lib
- implicit none
- integer :: x
- integer :: y
-
- integer, allocatable :: var1(:)
- integer, allocatable :: var2(:)
- integer, allocatable :: var3(:)
- integer, allocatable :: var4(:)
- integer, allocatable :: var5(:)
- integer, allocatable :: var6(:)
- integer, allocatable :: var7(:)
- integer, allocatable :: var8(:)
- integer, allocatable :: var9(:)
-
- x = 1 ! executable statement before '!$omp allocate'
-
- ! Don't use a hard-coded value (..., but it does pass the checks).
- !$omp allocate (var1) allocator(10_omp_allocator_handle_kind) ! { dg-bogus "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
- allocate (var1(x))
-
- ! Assumption is that 'omp_allocator_handle_kind' ('c_intptr_t') isn't 1.
- !$omp allocate (var1) allocator(10_1) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind at .1." }
- allocate (var1(x))
-
- !$omp allocate (var2) ! { dg-error "'var2' specified in 'allocate' at .1. but not in the associated ALLOCATE statement" }
- allocate (var3(x)) ! { dg-error "'var3' listed in 'allocate' statement at .1. but it is neither explicitly in listed in the '!.OMP ALLOCATE' directive nor exists a directive without argument list" }
-
- !$omp allocate (x)
- x = 2 ! { dg-error "Unexpected assignment at .1.; expected ALLOCATE or !.OMP ALLOCATE statement" }
-
- !$omp allocate (var4)
- y = 2 ! { dg-error "Unexpected assignment at .1.; expected ALLOCATE or !.OMP ALLOCATE statement" }
-
- !$omp allocate (var5)
- !$omp allocate
- allocate (var5(x))
-
- !$omp allocate (var6)
- !$omp allocate (var7) ! { dg-error "'var7' specified in 'allocate' at .1. but not in the associated ALLOCATE statement" }
- !$omp allocate (var8) ! { dg-error "'var8' specified in 'allocate' at .1. but not in the associated ALLOCATE statement" }
- allocate (var6(x))
-
- !$omp allocate (var9)
- !$omp allocate (var9) ! { dg-warning "var9' appears more than once in 'allocate'" }
- allocate (var9(x))
-
-end subroutine
-
-function outer(a)
- IMPLICIT NONE
-
- integer :: outer, a
- integer, allocatable :: var1
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_alloc \\(" 5 "gimple" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(" 5 "gimple" } }
- outer = inner(a) + 5
- return
- contains
-
- integer function inner(x)
- integer :: x
- integer, allocatable :: var2
-
- x = 1 ! executable statement before '!$omp allocate'
-
- !$omp allocate (var1, var2) ! { dg-error "Sorry, allocation of allocatable 'var1' with '!.omp allocators' or '!.omp allocate' at .1. is only suppored in the scope where it has been declared, unless it has the SAVE attribute" }
- allocate (var1, var2)
-
- inner = x + 10
- return
- end function inner
-
-end function outer
-
-subroutine bar(s)
+module m
use omp_lib
- use test
- integer :: s
- integer, save, allocatable :: svar1
- integer, save, allocatable :: svar2
- integer, save, allocatable :: svar3
-
- type (omp_alloctrait) :: traits(3)
- integer (omp_allocator_handle_kind) :: a
-
- traits = [omp_alloctrait (omp_atk_alignment, 64), &
- omp_alloctrait (omp_atk_fallback, omp_atv_null_fb), &
- omp_alloctrait (omp_atk_pool_size, 8192)]
- a = omp_init_allocator (omp_default_mem_space, 3, traits)
- if (a == omp_null_allocator) stop 1
-
- !$omp allocate (mvar1) allocator(a)
- allocate (mvar1)
-
- !$omp allocate (mvar2)
- allocate (mvar2)
-
- !$omp allocate (mvar3) allocator(omp_low_lat_mem_alloc)
- allocate (mvar3)
-
- !$omp allocate (svar1) allocator(a)
- allocate (svar1)
-
- !$omp allocate (svar2)
- allocate (svar2)
+ 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
- !$omp allocate (svar3) allocator(omp_low_lat_mem_alloc)
- allocate (svar3)
-end subroutine
+use m
+if (one () /= 1225) &
+ stop 1
+end
--- /dev/null
+! { dg-do compile }
+
+module test
+ integer, allocatable :: mvar1
+ integer, allocatable :: mvar2
+ integer, allocatable :: mvar3
+end module
+
+subroutine foo(x, y)
+ use omp_lib
+ implicit none
+ integer :: x
+ integer :: y
+
+ integer, allocatable :: var1(:)
+ integer, allocatable :: var2(:)
+ integer, allocatable :: var3(:)
+ integer, allocatable :: var4(:)
+ integer, allocatable :: var5(:)
+ integer, allocatable :: var6(:)
+ integer, allocatable :: var7(:)
+ integer, allocatable :: var8(:)
+ integer, allocatable :: var9(:)
+
+ x = 1 ! executable statement before '!$omp allocate'
+
+ ! Don't use a hard-coded value (..., but it does pass the checks).
+ !$omp allocate (var1) allocator(10_omp_allocator_handle_kind) ! { dg-bogus "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
+ allocate (var1(x))
+
+ ! Assumption is that 'omp_allocator_handle_kind' ('c_intptr_t') isn't 1.
+ !$omp allocate (var1) allocator(10_1) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind at .1." }
+ allocate (var1(x))
+
+ !$omp allocate (var2) ! { dg-error "'var2' specified in 'allocate' at .1. but not in the associated ALLOCATE statement" }
+ allocate (var3(x)) ! { dg-error "'var3' listed in 'allocate' statement at .1. but it is neither explicitly in listed in the '!.OMP ALLOCATE' directive nor exists a directive without argument list" }
+
+ !$omp allocate (x)
+ x = 2 ! { dg-error "Unexpected assignment at .1.; expected ALLOCATE or !.OMP ALLOCATE statement" }
+
+ !$omp allocate (var4)
+ y = 2 ! { dg-error "Unexpected assignment at .1.; expected ALLOCATE or !.OMP ALLOCATE statement" }
+
+ !$omp allocate (var5)
+ !$omp allocate
+ allocate (var5(x))
+
+ !$omp allocate (var6)
+ !$omp allocate (var7) ! { dg-error "'var7' specified in 'allocate' at .1. but not in the associated ALLOCATE statement" }
+ !$omp allocate (var8) ! { dg-error "'var8' specified in 'allocate' at .1. but not in the associated ALLOCATE statement" }
+ allocate (var6(x))
+
+ !$omp allocate (var9)
+ !$omp allocate (var9) ! { dg-warning "var9' appears more than once in 'allocate'" }
+ allocate (var9(x))
+
+end subroutine
+
+function outer(a)
+ IMPLICIT NONE
+
+ integer :: outer, a
+ integer, allocatable :: var1
+
+ outer = inner(a) + 5
+ return
+
+ contains
+
+ integer function inner(x)
+ integer :: x
+ integer, allocatable :: var2
+
+ x = 1 ! executable statement before '!$omp allocate'
+
+ !$omp allocate (var1, var2) ! { dg-error "Sorry, allocation of allocatable 'var1' with '!.omp allocators' or '!.omp allocate' at .1. is only suppored in the scope where it has been declared, unless it has the SAVE attribute" }
+ allocate (var1, var2)
+
+ inner = x + 10
+ return
+ end function inner
+
+end function outer
+
+subroutine bar(s)
+ use omp_lib
+ use test
+ integer :: s
+ integer, save, allocatable :: svar1
+ integer, save, allocatable :: svar2
+ integer, save, allocatable :: svar3
+
+ type (omp_alloctrait) :: traits(3)
+ integer (omp_allocator_handle_kind) :: a
+
+ traits = [omp_alloctrait (omp_atk_alignment, 64), &
+ omp_alloctrait (omp_atk_fallback, omp_atv_null_fb), &
+ omp_alloctrait (omp_atk_pool_size, 8192)]
+ a = omp_init_allocator (omp_default_mem_space, 3, traits)
+ if (a == omp_null_allocator) stop 1
+
+ !$omp allocate (mvar1) allocator(a)
+ allocate (mvar1)
+
+ !$omp allocate (mvar2)
+ allocate (mvar2)
+
+ !$omp allocate (mvar3) allocator(omp_low_lat_mem_alloc)
+ allocate (mvar3)
+
+ !$omp allocate (svar1) allocator(a)
+ allocate (svar1)
+
+ !$omp allocate (svar2)
+ allocate (svar2)
+
+ !$omp allocate (svar3) allocator(omp_low_lat_mem_alloc)
+ allocate (svar3)
+end subroutine
--- /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
