From: Tobias Burnus <tobias@codesourcery.com>
To: gcc-patches <gcc-patches@gcc.gnu.org>,
fortran <fortran@gcc.gnu.org>, Jakub Jelinek <jakub@redhat.com>
Subject: [Patch] Fortran: Support OpenMP's 'allocate' directive for stack vars
Date: Tue, 10 Oct 2023 18:46:35 +0200 [thread overview]
Message-ID: <457ea120-5cca-48e0-89d6-c3eab4234b61@codesourcery.com> (raw)
[-- Attachment #1: Type: text/plain, Size: 1635 bytes --]
The attached patch adds 'omp allocate' support for stack/automatic variables
variables for Fortran.
I had originally a pure FE version for Fortran, which failed with 'defaultmap'/'default';
I then thought I could simply piggyback on the existing C/C++ support.
But it turns out that Fortran is completely different, e.g. there is often no BIND_EXPR
but just some (scoped / try-final-expr) code inside of it, i.e. the scope of the BIND_EXPR
has no relation to where GOMP_alloc has to be added. (GOMP_free is less critical, except
that a longer lifetime might cause memory constraints.)
Thus, RFC:
- Is the current scheme okay or should me move moved to the FE
there is not that much happening at the ME?
- Should for the one 'if (lang_GNU_Fortran () ...' condition a lang hook
be introduced?
Any other suggestions?
ALSO: I decided that the wording permits 'type(c_ptr)', 'type(c_funptr)' as they are
rather normal variables (of opaque type) in the Fortran sense. I decided that we do
not want to support EQUIVALENCE, Cray pointers, COMMON blocks ever (even though the
first to surely could be made to work, the latter - maybe.)
I also reject coarrays as it is really incompatible for allocate/allocators; for
the 'allocate' clause, that's different and permitted (just used for privatization).
Thoughts, suggestions?
Tobias
-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955
[-- Attachment #2: omp-allocate-fortran.diff --]
[-- Type: text/x-patch, Size: 79184 bytes --]
Fortran: Support OpenMP's 'allocate' directive for stack vars
gcc/fortran/ChangeLog:
* gfortran.h (ext_attr_t): Add omp_allocate flag.
* match.cc (gfc_free_omp_namelist): Void deleting same
u2.allocator multiple times now that a sequence can use
the same one.
* openmp.cc (gfc_match_omp_clauses, gfc_match_omp_allocate): Use
same allocator expr multiple times.
(is_predefined_allocator): Make static.
(gfc_resolve_omp_allocate): Update/extend restriction checks;
remove sorry message.
(resolve_omp_clauses): Reject corarrays in allocate/allocators
directive.
* parse.cc (check_omp_allocate_stmt): Permit procedure pointers
here (rejected later) for less mislreading diagnostic.
* trans-array.cc (gfc_trans_auto_array_allocation): Propagate
size for GOMP_alloc and location to which it should be added to.
* trans-decl.cc (gfc_trans_deferred_vars): Handle 'omp allocate'
for stack variables; sorry for static variables/common blocks.
* trans-openmp.cc (gfc_trans_omp_clauses): Evaluate 'allocate'
clause's allocator only once; fix adding expressions to the
block.
(gfc_trans_omp_single): Pass a block to gfc_trans_omp_clauses.
gcc/ChangeLog:
* gimplify.cc (gimplify_bind_expr): Handle Fortran's
'omp allocate' for stack variables.
libgomp/ChangeLog:
* libgomp.texi:
* testsuite/libgomp.fortran/allocate-5.f90: New test.
* testsuite/libgomp.fortran/allocate-6.f90: New test.
* testsuite/libgomp.fortran/allocate-7.f90: New test.
* testsuite/libgomp.fortran/allocate-8.f90: New test.
gcc/testsuite/ChangeLog:
* c-c++-common/gomp/allocate-14.c: Fix directive name.
* c-c++-common/gomp/allocate-15.c: Likewise.
* c-c++-common/gomp/allocate-9.c: Fix comment typo.
* gfortran.dg/gomp/allocate-4.f90: Remove sorry dg-error.
* gfortran.dg/gomp/allocate-7.f90: Likewise.
* gfortran.dg/gomp/allocate-10.f90: New test.
* gfortran.dg/gomp/allocate-11.f90: New test.
* gfortran.dg/gomp/allocate-12.f90: New test.
* gfortran.dg/gomp/allocate-13.f90: New test.
* gfortran.dg/gomp/allocate-14.f90: New test.
* gfortran.dg/gomp/allocate-15.f90: New test.
* gfortran.dg/gomp/allocate-8.f90: New test.
* gfortran.dg/gomp/allocate-9.f90: New test.
gcc/fortran/gfortran.h | 1 +
gcc/fortran/match.cc | 9 +-
gcc/fortran/openmp.cc | 62 +++-
gcc/fortran/parse.cc | 8 +-
gcc/fortran/trans-array.cc | 28 +-
gcc/fortran/trans-decl.cc | 121 ++++++++
gcc/fortran/trans-openmp.cc | 77 +++--
gcc/gimplify.cc | 173 +++++++++---
gcc/testsuite/c-c++-common/gomp/allocate-14.c | 2 +-
gcc/testsuite/c-c++-common/gomp/allocate-15.c | 2 +-
gcc/testsuite/c-c++-common/gomp/allocate-9.c | 2 +-
gcc/testsuite/gfortran.dg/gomp/allocate-10.f90 | 74 +++++
gcc/testsuite/gfortran.dg/gomp/allocate-11.f90 | 33 +++
gcc/testsuite/gfortran.dg/gomp/allocate-12.f90 | 24 ++
gcc/testsuite/gfortran.dg/gomp/allocate-13.f90 | 25 ++
gcc/testsuite/gfortran.dg/gomp/allocate-14.f90 | 95 +++++++
gcc/testsuite/gfortran.dg/gomp/allocate-15.f90 | 38 +++
gcc/testsuite/gfortran.dg/gomp/allocate-4.f90 | 4 +-
gcc/testsuite/gfortran.dg/gomp/allocate-7.f90 | 10 -
gcc/testsuite/gfortran.dg/gomp/allocate-8.f90 | 29 ++
gcc/testsuite/gfortran.dg/gomp/allocate-9.f90 | 112 ++++++++
libgomp/libgomp.texi | 4 +-
libgomp/testsuite/libgomp.fortran/allocate-5.f90 | 87 ++++++
libgomp/testsuite/libgomp.fortran/allocate-6.f90 | 123 ++++++++
libgomp/testsuite/libgomp.fortran/allocate-7.f90 | 342 +++++++++++++++++++++++
libgomp/testsuite/libgomp.fortran/allocate-8.f90 | 99 +++++++
26 files changed, 1480 insertions(+), 104 deletions(-)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 6caf7765ac6..88f33b0957e 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1000,6 +1000,7 @@ typedef struct
unsigned omp_declare_target:1;
unsigned omp_declare_target_link:1;
ENUM_BITFIELD (gfc_omp_device_type) omp_device_type:2;
+ unsigned omp_allocate:1;
/* Mentioned in OACC DECLARE. */
unsigned oacc_declare_create:1;
diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc
index c926f38058f..148a86bb436 100644
--- a/gcc/fortran/match.cc
+++ b/gcc/fortran/match.cc
@@ -5541,6 +5541,7 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns,
bool free_mem_traits_space)
{
gfc_omp_namelist *n;
+ gfc_expr *last_allocator = NULL;
for (; name; name = n)
{
@@ -5552,7 +5553,13 @@ gfc_free_omp_namelist (gfc_omp_namelist *name, bool free_ns,
if (free_ns)
gfc_free_namespace (name->u2.ns);
else if (free_align_allocator)
- gfc_free_expr (name->u2.allocator);
+ {
+ if (last_allocator != name->u2.allocator)
+ {
+ last_allocator = name->u2.allocator;
+ gfc_free_expr (name->u2.allocator);
+ }
+ }
else if (free_mem_traits_space)
{ } /* name->u2.traits_sym: shall not call gfc_free_symbol here. */
else if (name->u2.udr)
diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc
index 79b5ae0e4bd..ca6dce91f65 100644
--- a/gcc/fortran/openmp.cc
+++ b/gcc/fortran/openmp.cc
@@ -2032,11 +2032,9 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const omp_mask mask,
for (gfc_omp_namelist *n = *head; n; n = n->next)
{
- n->u2.allocator = ((allocator)
- ? gfc_copy_expr (allocator) : NULL);
+ n->u2.allocator = allocator;
n->u.align = (align) ? gfc_copy_expr (align) : NULL;
}
- gfc_free_expr (allocator);
gfc_free_expr (align);
continue;
}
@@ -4547,9 +4545,8 @@ gfc_match_omp_allocate (void)
for (; vars; vars = vars->next)
{
vars->u.align = (align) ? gfc_copy_expr (align) : NULL;
- vars->u2.allocator = ((allocator) ? gfc_copy_expr (allocator) : NULL);
+ vars->u2.allocator = allocator;
}
- gfc_free_expr (allocator);
gfc_free_expr (align);
}
return MATCH_YES;
@@ -7191,7 +7188,7 @@ resolve_omp_udr_clause (gfc_omp_namelist *n, gfc_namespace *ns,
/* Assume that a constant expression in the range 1 (omp_default_mem_alloc)
to 8 (omp_thread_mem_alloc) range is fine. The original symbol name is
already lost during matching via gfc_match_expr. */
-bool
+static bool
is_predefined_allocator (gfc_expr *expr)
{
return (gfc_resolve_expr (expr)
@@ -7209,10 +7206,20 @@ is_predefined_allocator (gfc_expr *expr)
void
gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
{
- for (gfc_omp_namelist *n = list; n; n = n->next)
- n->sym->mark = 0;
for (gfc_omp_namelist *n = list; n; n = n->next)
{
+ if (n->sym->attr.result || n->sym->result == n->sym)
+ {
+ gfc_error ("Unexpected function-result variable %qs at %L in "
+ "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
+ continue;
+ }
+ if (ns->omp_allocate->sym->attr.proc_pointer)
+ {
+ gfc_error ("Procedure pointer %qs not supported with !$OMP "
+ "ALLOCATE at %L", n->sym->name, &n->where);
+ continue;
+ }
if (n->sym->attr.flavor != FL_VARIABLE)
{
gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE "
@@ -7220,8 +7227,7 @@ gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
&n->where);
continue;
}
- if (ns != n->sym->ns || n->sym->attr.use_assoc
- || n->sym->attr.host_assoc || n->sym->attr.imported)
+ if (ns != n->sym->ns || n->sym->attr.use_assoc || n->sym->attr.imported)
{
gfc_error ("Argument %qs at %L to declarative !$OMP ALLOCATE shall be"
" in the same scope as the variable declaration",
@@ -7234,7 +7240,13 @@ gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
"declarative !$OMP ALLOCATE", n->sym->name, &n->where);
continue;
}
- if (n->sym->mark)
+ if (n->sym->attr.codimension)
+ {
+ gfc_error ("Unexpected coarray argument %qs as argument at %L to "
+ "declarative !$OMP ALLOCATE", n->sym->name, &n->where);
+ continue;
+ }
+ if (n->sym->attr.omp_allocate)
{
if (n->sym->attr.in_common)
{
@@ -7249,7 +7261,28 @@ gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
n->sym->name, &n->where);
continue;
}
- n->sym->mark = 1;
+ /* For 'equivalence(a,b)', a 'union_type {<type> a,b} equiv.0' is created
+ with a value expression for 'a' as 'equiv.0.a' (likewise for b); while
+ this can be handled, EQUIVALENCE is marked as obsolescent since Fortran
+ 2018 and also not widely used. However, it could be supported,
+ if needed. */
+ if (n->sym->attr.in_equivalence)
+ {
+ gfc_error ("Sorry, EQUIVALENCE object %qs not supported with !$OMP "
+ "ALLOCATE at %L", n->sym->name, &n->where);
+ continue;
+ }
+ /* Similar for Cray pointer/pointee - they could be implemented but as
+ common vendor extension but nowadays rarely used and requiring
+ -fcray-pointer, there is no need to support them. */
+ if (n->sym->attr.cray_pointer || n->sym->attr.cray_pointee)
+ {
+ gfc_error ("Sorry, Cray pointers and pointees such as %qs are not "
+ "supported with !$OMP ALLOCATE at %L",
+ n->sym->name, &n->where);
+ continue;
+ }
+ n->sym->attr.omp_allocate = 1;
if ((n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok
&& CLASS_DATA (n->sym)->attr.allocatable)
|| (n->sym->ts.type != BT_CLASS && n->sym->attr.allocatable))
@@ -7307,8 +7340,6 @@ gfc_resolve_omp_allocate (gfc_namespace *ns, gfc_omp_namelist *list)
"%<omp_allocator_handle_kind%> kind at %L",
&n->u2.allocator->where);
}
- gfc_error ("Sorry, declarative !$OMP ALLOCATE at %L not yet supported",
- &list->where);
}
/* Resolve ASSUME's and ASSUMES' assumption clauses. Note that absent/contains
@@ -7897,6 +7928,9 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses *omp_clauses,
{
if (n->sym == NULL)
continue;
+ if (n->sym->attr.codimension)
+ gfc_error ("Unexpected coarray %qs in %<allocate%> at %L",
+ n->sym->name, &n->where);
for (a = code->block->next->ext.alloc.list; a; a = a->next)
if (a->expr->expr_type == EXPR_VARIABLE
&& a->expr->symtree->n.sym == n->sym)
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index 444baf42cbd..e103ebee557 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -833,18 +833,18 @@ check_omp_allocate_stmt (locus *loc)
&n->expr->where, gfc_ascii_statement (ST_OMP_ALLOCATE));
return false;
}
+ /* Procedure pointers are not allocatable; hence, we do not regard them as
+ pointers here - and reject them later in gfc_resolve_omp_allocate. */
bool alloc_ptr;
if (n->sym->ts.type == BT_CLASS && n->sym->attr.class_ok)
alloc_ptr = (CLASS_DATA (n->sym)->attr.allocatable
|| CLASS_DATA (n->sym)->attr.class_pointer);
else
- alloc_ptr = (n->sym->attr.allocatable || n->sym->attr.pointer
- || n->sym->attr.proc_pointer);
+ alloc_ptr = n->sym->attr.allocatable || n->sym->attr.pointer;
if (alloc_ptr
|| (n->sym->ns && n->sym->ns->proc_name
&& (n->sym->ns->proc_name->attr.allocatable
- || n->sym->ns->proc_name->attr.pointer
- || n->sym->ns->proc_name->attr.proc_pointer)))
+ || n->sym->ns->proc_name->attr.pointer)))
has_allocatable = true;
else
has_non_allocatable = true;
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 8e94a9a469f..bbb81f40aa9 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -82,6 +82,9 @@ along with GCC; see the file COPYING3. If not see
#include "tree.h"
#include "gfortran.h"
#include "gimple-expr.h"
+#include "tree-iterator.h"
+#include "stringpool.h" /* Required by "attribs.h". */
+#include "attribs.h" /* For lookup_attribute. */
#include "trans.h"
#include "fold-const.h"
#include "constructor.h"
@@ -6770,6 +6773,15 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
gimplifier to allocate storage, and all that good stuff. */
tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
gfc_add_expr_to_block (&init, tmp);
+ if (sym->attr.omp_allocate)
+ {
+ /* Save location of size calculation to ensure GOMP_alloc is placed
+ after it. */
+ tree omp_alloc = lookup_attribute ("omp allocate",
+ DECL_ATTRIBUTES (decl));
+ TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
+ = build_tree_list (NULL_TREE, tsi_stmt (tsi_last (init.head)));
+ }
}
if (onstack)
@@ -6798,8 +6810,22 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym,
gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
return;
}
+ if (sym->attr.omp_allocate)
+ {
+ /* The size is the number of elements in the array, so multiply by the
+ size of an element to get the total size. */
+ tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type));
+ size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
+ size, fold_convert (gfc_array_index_type, tmp));
+ size = gfc_evaluate_now (size, &init);
- if (flag_stack_arrays)
+ tree omp_alloc = lookup_attribute ("omp allocate",
+ DECL_ATTRIBUTES (decl));
+ TREE_CHAIN (TREE_CHAIN (TREE_VALUE (omp_alloc)))
+ = build_tree_list (size, NULL_TREE);
+ space = NULL_TREE;
+ }
+ else if (flag_stack_arrays)
{
gcc_assert (TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE);
space = build_decl (gfc_get_location (&sym->declared_at),
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index b0fd25e92a3..dfd58bf60a5 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -48,6 +48,7 @@ along with GCC; see the file COPYING3. If not see
#include "gimplify.h"
#include "omp-general.h"
#include "attr-fnspec.h"
+#include "tree-iterator.h"
#define MAX_LABEL_VALUE 99999
@@ -4652,6 +4653,36 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
init_intent_out_dt (proc_sym, block);
gfc_restore_backend_locus (&loc);
+ /* For some reasons, internal procedures point to the parent's
+ namespace. Top-level procedure and variables inside BLOCK are fine. */
+ gfc_namespace *omp_ns = proc_sym->ns;
+ if (proc_sym->ns->proc_name != proc_sym)
+ for (omp_ns = proc_sym->ns->contained; omp_ns;
+ omp_ns = omp_ns->sibling)
+ if (omp_ns->proc_name == proc_sym)
+ break;
+
+ /* Add 'omp allocate' attribute for gfc_trans_auto_array_allocation and
+ unset attr.omp_allocate for 'omp allocate allocator(omp_default_mem_alloc),
+ which has the normal codepath except for an invalid-use check in the ME.
+ The main processing happens later in this function. */
+ for (struct gfc_omp_namelist *n = omp_ns ? omp_ns->omp_allocate : NULL;
+ n; n = n->next)
+ if (!TREE_STATIC (n->sym->backend_decl))
+ {
+ /* Add empty entries - described and to be filled below. */
+ tree tmp = build_tree_list (NULL_TREE, NULL_TREE);
+ TREE_CHAIN (tmp) = build_tree_list (NULL_TREE, NULL_TREE);
+ DECL_ATTRIBUTES (n->sym->backend_decl)
+ = tree_cons (get_identifier ("omp allocate"), tmp,
+ DECL_ATTRIBUTES (n->sym->backend_decl));
+ if (n->u.align == NULL
+ && n->u2.allocator != NULL
+ && n->u2.allocator->expr_type == EXPR_CONSTANT
+ && mpz_cmp_si (n->u2.allocator->value.integer, 1) == 0)
+ n->sym->attr.omp_allocate = 0;
+ }
+
for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
{
bool alloc_comp_or_fini = (sym->ts.type == BT_DERIVED)
@@ -5105,6 +5136,96 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
gcc_unreachable ();
}
+ /* Handle 'omp allocate'. This has to be after the block above as
+ gfc_add_init_cleanup (..., init, ...) puts 'init' of later calls
+ before earlier calls. The code is a bit more complex as gfortran does
+ not really work with bind expressions / BIND_EXPR_VARS properly, i.e.
+ gimplify_bind_expr needs some help for placing the GOMP_alloc. Thus,
+ we pass on the location of the allocate-assignment expression and,
+ if the size is not constant, the size variable if Fortran computes this
+ differently. We also might add an expression location after which the
+ code has to be added, e.g. for character len expressions, which affect
+ the UNIT_SIZE. */
+ gfc_expr *last_allocator = NULL;
+ if (omp_ns && omp_ns->omp_allocate)
+ {
+ if (!block->init || TREE_CODE (block->init) != STATEMENT_LIST)
+ {
+ tree tmp = build1_v (LABEL_EXPR, gfc_build_label_decl (NULL_TREE));
+ append_to_statement_list (tmp, &block->init);
+ }
+ if (!block->cleanup || TREE_CODE (block->cleanup) != STATEMENT_LIST)
+ {
+ tree tmp = build1_v (LABEL_EXPR, gfc_build_label_decl (NULL_TREE));
+ append_to_statement_list (tmp, &block->cleanup);
+ }
+ }
+ tree init_stmtlist = block->init;
+ tree cleanup_stmtlist = block->cleanup;
+ se.expr = NULL_TREE;
+ for (struct gfc_omp_namelist *n = omp_ns ? omp_ns->omp_allocate : NULL;
+ n; n = n->next)
+ if (!TREE_STATIC (n->sym->backend_decl))
+ {
+ tree align = (n->u.align ? gfc_conv_constant_to_tree (n->u.align)
+ : NULL_TREE);
+ if (last_allocator != n->u2.allocator)
+ {
+ gfc_init_se (&se, NULL);
+ if (n->u2.allocator)
+ 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;
+ }
+
+ /* '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)
diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc
index 2f116fd6738..7930f2fd5d1 100644
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -2739,34 +2739,48 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
}
break;
case OMP_LIST_ALLOCATE:
- for (; n != NULL; n = n->next)
- if (n->sym->attr.referenced)
- {
- tree t = gfc_trans_omp_variable (n->sym, false);
- if (t != error_mark_node)
- {
- tree node = build_omp_clause (input_location,
- OMP_CLAUSE_ALLOCATE);
- OMP_CLAUSE_DECL (node) = t;
- if (n->u2.allocator)
- {
- tree allocator_;
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, n->u2.allocator);
- allocator_ = gfc_evaluate_now (se.expr, block);
- OMP_CLAUSE_ALLOCATE_ALLOCATOR (node) = allocator_;
- }
- if (n->u.align)
- {
- tree align_;
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, n->u.align);
- align_ = gfc_evaluate_now (se.expr, block);
- OMP_CLAUSE_ALLOCATE_ALIGN (node) = align_;
- }
- omp_clauses = gfc_trans_add_clause (node, omp_clauses);
- }
- }
+ {
+ tree allocator_ = NULL_TREE;
+ gfc_expr *alloc_expr = NULL;
+ for (; n != NULL; n = n->next)
+ if (n->sym->attr.referenced)
+ {
+ tree t = gfc_trans_omp_variable (n->sym, false);
+ if (t != error_mark_node)
+ {
+ tree node = build_omp_clause (input_location,
+ OMP_CLAUSE_ALLOCATE);
+ OMP_CLAUSE_DECL (node) = t;
+ if (n->u2.allocator)
+ {
+ if (alloc_expr != n->u2.allocator)
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, n->u2.allocator);
+ gfc_add_block_to_block (block, &se.pre);
+ allocator_ = gfc_evaluate_now (se.expr, block);
+ gfc_add_block_to_block (block, &se.post);
+ }
+ OMP_CLAUSE_ALLOCATE_ALLOCATOR (node) = allocator_;
+ }
+ alloc_expr = n->u2.allocator;
+ if (n->u.align)
+ {
+ tree align_;
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, n->u.align);
+ gcc_assert (CONSTANT_CLASS_P (se.expr)
+ && se.pre.head == NULL
+ && se.post.head == NULL);
+ align_ = se.expr;
+ OMP_CLAUSE_ALLOCATE_ALIGN (node) = align_;
+ }
+ omp_clauses = gfc_trans_add_clause (node, omp_clauses);
+ }
+ }
+ else
+ alloc_expr = n->u2.allocator;
+ }
break;
case OMP_LIST_LINEAR:
{
@@ -7184,11 +7198,14 @@ gfc_trans_omp_sections (gfc_code *code, gfc_omp_clauses *clauses)
static tree
gfc_trans_omp_single (gfc_code *code, gfc_omp_clauses *clauses)
{
- tree omp_clauses = gfc_trans_omp_clauses (NULL, clauses, code->loc);
+ stmtblock_t block;
+ gfc_start_block (&block);
+ tree omp_clauses = gfc_trans_omp_clauses (&block, clauses, code->loc);
tree stmt = gfc_trans_omp_code (code->block->next, true);
stmt = build2_loc (gfc_get_location (&code->loc), OMP_SINGLE, void_type_node,
stmt, omp_clauses);
- return stmt;
+ gfc_add_expr_to_block (&block, stmt);
+ return gfc_finish_block (&block);
}
static tree
diff --git a/gcc/gimplify.cc b/gcc/gimplify.cc
index 9f4722f7458..402d9feaf9b 100644
--- a/gcc/gimplify.cc
+++ b/gcc/gimplify.cc
@@ -1400,23 +1400,53 @@ gimplify_bind_expr (tree *expr_p, gimple_seq *pre_p)
"region must specify an %<allocator%> clause", t);
/* Skip for omp_default_mem_alloc (= 1),
unless align is present. */
- else if (!errorcount
- && (align != NULL_TREE
- || alloc == NULL_TREE
- || !integer_onep (alloc)))
+ else if (errorcount
+ || (align == NULL_TREE
+ && alloc != NULL_TREE
+ && integer_onep (alloc)))
+ DECL_ATTRIBUTES (t) = remove_attribute ("omp allocate",
+ DECL_ATTRIBUTES (t));
+ else
{
- 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;
+ 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 (type);
+ /* The size to use in Fortran might not match TYPE_SIZE_UNIT;
+ hence, for some decls, a size variable is saved in the
+ attributes; use it, if available. */
+ if (TREE_CHAIN (TREE_VALUE (attr))
+ && TREE_CHAIN (TREE_CHAIN (TREE_VALUE (attr)))
+ && TREE_PURPOSE (
+ TREE_CHAIN (TREE_CHAIN (TREE_VALUE (attr)))))
+ {
+ sz = TREE_CHAIN (TREE_CHAIN (TREE_VALUE (attr)));
+ sz = TREE_PURPOSE (sz);
+ }
if (alloc == NULL_TREE)
alloc = build_zero_cst (ptr_type_node);
if (align == NULL_TREE)
@@ -1425,28 +1455,88 @@ gimplify_bind_expr (tree *expr_p, gimple_seq *pre_p)
align = build_int_cst (size_type_node,
MAX (tree_to_uhwi (align),
DECL_ALIGN_UNIT (t)));
+ location_t loc = DECL_SOURCE_LOCATION (t);
tmp = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC);
- tmp = build_call_expr_loc (DECL_SOURCE_LOCATION (t), tmp,
- 3, align, sz, alloc);
- tmp = fold_build2_loc (DECL_SOURCE_LOCATION (t), MODIFY_EXPR,
- TREE_TYPE (v), v,
+ tmp = build_call_expr_loc (loc, tmp, 3, align, sz, alloc);
+ tmp = fold_build2_loc (loc, MODIFY_EXPR, TREE_TYPE (v), v,
fold_convert (TREE_TYPE (v), tmp));
- gcc_assert (BIND_EXPR_BODY (bind_expr) != NULL_TREE
- && (TREE_CODE (BIND_EXPR_BODY (bind_expr))
- == STATEMENT_LIST));
- tree_stmt_iterator e = tsi_start (BIND_EXPR_BODY (bind_expr));
- while (!tsi_end_p (e))
+ gcc_assert (BIND_EXPR_BODY (bind_expr) != NULL_TREE);
+ if (TREE_CHAIN (TREE_VALUE (attr)))
{
- if ((TREE_CODE (*e) == DECL_EXPR
- && TREE_OPERAND (*e, 0) == t)
- || (TREE_CODE (*e) == CLEANUP_POINT_EXPR
- && TREE_CODE (TREE_OPERAND (*e, 0)) == DECL_EXPR
- && TREE_OPERAND (TREE_OPERAND (*e, 0), 0) == t))
- break;
+ /* Fortran is special as it does not have properly nest
+ declarations in blocks. And as there is no
+ initializer, there is also no expression to look for.
+ Hence, the FE makes the statement list of the
+ try-finally block available. We can put the GOMP_alloc
+ at the top, unless an allocator or size expression
+ requires to put it afterward; note that the size is
+ always later in generated code; for strings, no
+ size expr but still an expr might be available. */
+ tree sl = TREE_PURPOSE (TREE_CHAIN (TREE_VALUE (attr)));
+ tree_stmt_iterator e = tsi_start (sl);
+ tree needle = NULL_TREE;
+ if (TREE_CHAIN (TREE_CHAIN (TREE_VALUE (attr))))
+ {
+ needle = TREE_CHAIN (TREE_CHAIN (TREE_VALUE (attr)));
+ needle = (TREE_VALUE (needle) ? TREE_VALUE (needle)
+ : sz);
+ }
+ else if (TREE_CHAIN (TREE_CHAIN (TREE_VALUE (attr))))
+ needle = sz;
+ else if (DECL_P (alloc) && DECL_ARTIFICIAL (alloc))
+ needle = alloc;
+
+ if (needle != NULL_TREE)
+ {
+ while (!tsi_end_p (e))
+ {
+ if (*e == needle
+ || (TREE_CODE (*e) == MODIFY_EXPR
+ && TREE_OPERAND (*e, 0) == needle))
+ break;
+ ++e;
+ }
+ gcc_assert (!tsi_end_p (e));
+ }
+ tsi_link_after (&e, tmp, TSI_SAME_STMT);
+
+ /* As the cleanup is in BIND_EXPR_BODY, GOMP_free is added
+ here; for C/C++ it will be added in the 'cleanup'
+ section after gimplification. But Fortran already has
+ a try-finally block. */
+ sl = TREE_VALUE (TREE_CHAIN (TREE_VALUE (attr)));
+ e = tsi_last (sl);
+ tmp = builtin_decl_explicit (BUILT_IN_GOMP_FREE);
+ tmp = build_call_expr_loc (EXPR_LOCATION (*e), tmp, 2, v,
+ build_zero_cst (ptr_type_node));
+ tsi_link_after (&e, tmp, TSI_SAME_STMT);
+ tmp = build_clobber (TREE_TYPE (v), CLOBBER_EOL);
+ tmp = fold_build2_loc (loc, MODIFY_EXPR, TREE_TYPE (v), v,
+ fold_convert (TREE_TYPE (v), tmp));
++e;
+ tsi_link_after (&e, tmp, TSI_SAME_STMT);
}
- gcc_assert (!tsi_end_p (e));
- tsi_link_before (&e, tmp, TSI_SAME_STMT);
+ else
+ {
+ gcc_assert (TREE_CODE (BIND_EXPR_BODY (bind_expr))
+ == STATEMENT_LIST);
+ tree_stmt_iterator e;
+ e = tsi_start (BIND_EXPR_BODY (bind_expr));
+ while (!tsi_end_p (e))
+ {
+ if ((TREE_CODE (*e) == DECL_EXPR
+ && TREE_OPERAND (*e, 0) == t)
+ || (TREE_CODE (*e) == CLEANUP_POINT_EXPR
+ && (TREE_CODE (TREE_OPERAND (*e, 0))
+ == DECL_EXPR)
+ && (TREE_OPERAND (TREE_OPERAND (*e, 0), 0)
+ == t)))
+ break;
+ ++e;
+ }
+ gcc_assert (!tsi_end_p (e));
+ tsi_link_before (&e, tmp, TSI_SAME_STMT);
+ }
}
}
@@ -1539,16 +1629,25 @@ gimplify_bind_expr (tree *expr_p, gimple_seq *pre_p)
&& !is_global_var (t)
&& DECL_CONTEXT (t) == current_function_decl)
{
+ tree attr;
if (flag_openmp
- && DECL_HAS_VALUE_EXPR_P (t)
&& TREE_USED (t)
- && lookup_attribute ("omp allocate", DECL_ATTRIBUTES (t)))
+ && ((attr = lookup_attribute ("omp allocate",
+ DECL_ATTRIBUTES (t))) != NULL_TREE)
+ && TREE_CHAIN (TREE_VALUE (attr)) == NULL_TREE)
{
+ /* For Fortran, the GOMP_free has already been added above. */
+ tree v = (DECL_HAS_VALUE_EXPR_P (t)
+ ? TREE_OPERAND (DECL_VALUE_EXPR (t), 0) : t);
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)
diff --git a/gcc/testsuite/c-c++-common/gomp/allocate-14.c b/gcc/testsuite/c-c++-common/gomp/allocate-14.c
index b25da5497c5..894921a76d5 100644
--- a/gcc/testsuite/c-c++-common/gomp/allocate-14.c
+++ b/gcc/testsuite/c-c++-common/gomp/allocate-14.c
@@ -17,7 +17,7 @@ h ()
{
#pragma omp target
#pragma omp parallel
- #pragma omp serial
+ #pragma omp single
{
int var2[5]; /* { dg-error "'allocate' directive for 'var2' inside a target region must specify an 'allocator' clause" } */
#pragma omp allocate(var2)
diff --git a/gcc/testsuite/c-c++-common/gomp/allocate-15.c b/gcc/testsuite/c-c++-common/gomp/allocate-15.c
index 15105b9102e..52cb7686b7b 100644
--- a/gcc/testsuite/c-c++-common/gomp/allocate-15.c
+++ b/gcc/testsuite/c-c++-common/gomp/allocate-15.c
@@ -19,7 +19,7 @@ h ()
{
#pragma omp target
#pragma omp parallel
- #pragma omp serial
+ #pragma omp single
{
int var2[5];
#pragma omp allocate(var2)
diff --git a/gcc/testsuite/c-c++-common/gomp/allocate-9.c b/gcc/testsuite/c-c++-common/gomp/allocate-9.c
index 3c11080dd16..31382748be6 100644
--- a/gcc/testsuite/c-c++-common/gomp/allocate-9.c
+++ b/gcc/testsuite/c-c++-common/gomp/allocate-9.c
@@ -20,7 +20,7 @@ typedef enum omp_allocator_handle_t
static int A[5] = {1,2,3,4,5};
int B, C, D;
-/* If the following fails bacause of added predefined allocators, please update
+/* If the following fails because of added predefined allocators, please update
- c/c-parser.c's c_parser_omp_allocate
- fortran/openmp.cc's is_predefined_allocator
- libgomp/env.c's parse_allocator
diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-10.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-10.f90
new file mode 100644
index 00000000000..339aa3a97fb
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/allocate-10.f90
@@ -0,0 +1,74 @@
+! { 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) ! { dg-warning "'my_handle' is used uninitialized" }
+ !$omp allocate(B1) allocator(my_handle)
+ B1(1) = 5
+ ! { dg-final { scan-tree-dump-times "b1.\[0-9\]+ = __builtin_GOMP_alloc \\(4, 12, my_handle\\);" 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) ! { dg-warning "'my_handle' is used uninitialized" }
+ !$omp allocate(B2) allocator(my_handle) ! No dump as 'B2' is unused
+ ! by matching 'B2' above, TREE_USE is set. Hence:
+ ! { dg-final { scan-tree-dump-times "b2.\[0-9\]+ = __builtin_GOMP_alloc \\(4, 12, my_handle\\);" 1 "gimple" } }
+ ! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(b2.\[0-9\]+, 0B\\);" 1 "gimple" } }
+ end block
+end
diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-11.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-11.f90
new file mode 100644
index 00000000000..8a8d93930b0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/allocate-11.f90
@@ -0,0 +1,33 @@
+module m
+use iso_c_binding
+integer, parameter :: omp_allocator_handle_kind = c_intptr_t
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_null_allocator = 0
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_default_mem_alloc = 1
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_large_cap_mem_alloc = 2
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_const_mem_alloc = 3
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_high_bw_mem_alloc = 4
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_low_lat_mem_alloc = 5
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_cgroup_mem_alloc = 6
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_pteam_mem_alloc = 7
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_thread_mem_alloc = 8
+end
+
+subroutine f ()
+ use m
+ implicit none
+ integer :: i
+ !$omp parallel firstprivate(i) allocate(allocator(omp_low_latency_mem_alloc): i)
+ ! { dg-error "Symbol 'omp_low_latency_mem_alloc' at .1. has no IMPLICIT type; did you mean 'omp_low_lat_mem_alloc'\\\?" "" { target *-*-* } .-1 }
+ ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind at .1." "" { target *-*-* } .-2 }
+ i = 4
+ !$omp end parallel
+end
diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-12.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-12.f90
new file mode 100644
index 00000000000..183c2941819
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/allocate-12.f90
@@ -0,0 +1,24 @@
+module m
+ implicit none
+contains
+subroutine f ()
+ !$omp declare target
+ integer :: var ! { dg-error "'allocate' directive for 'var' inside a target region must specify an 'allocator' clause" }
+ !$omp allocate(var)
+ var = 5
+end
+
+subroutine h ()
+ !$omp target
+ !$omp parallel
+ !$omp single
+ block
+ integer :: var2(5) ! { dg-error "'allocate' directive for 'var2' inside a target region must specify an 'allocator' clause" }
+ !$omp allocate(var2)
+ var2(1) = 7
+ end block
+ !$omp end single
+ !$omp end parallel
+ !$omp end target
+end
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-13.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-13.f90
new file mode 100644
index 00000000000..bf8a5a2bee2
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/allocate-13.f90
@@ -0,0 +1,25 @@
+module m
+ implicit none
+ !$omp requires dynamic_allocators
+contains
+subroutine f ()
+ !$omp declare target
+ integer :: var
+ !$omp allocate(var)
+ var = 5
+end
+
+subroutine h ()
+ !$omp target
+ !$omp parallel
+ !$omp single
+ block
+ integer :: var2(5)
+ !$omp allocate(var2)
+ var2(1) = 7
+ end block
+ !$omp end single
+ !$omp end parallel
+ !$omp end target
+end
+end module
diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-14.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-14.f90
new file mode 100644
index 00000000000..8ff9c252e49
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/allocate-14.f90
@@ -0,0 +1,95 @@
+! { dg-additional-options "-fcoarray=single -fcray-pointer" }
+
+module m
+use iso_c_binding
+integer, parameter :: omp_allocator_handle_kind = c_intptr_t
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_null_allocator = 0
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_default_mem_alloc = 1
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_large_cap_mem_alloc = 2
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_const_mem_alloc = 3
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_high_bw_mem_alloc = 4
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_low_lat_mem_alloc = 5
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_cgroup_mem_alloc = 6
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_pteam_mem_alloc = 7
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_thread_mem_alloc = 8
+end
+
+subroutine coarrays(x)
+ use m
+ implicit none
+
+ integer :: x[*]
+ integer, allocatable :: y[:], z(:)[:]
+
+ !$omp allocate(x) ! { dg-error "Unexpected dummy argument 'x' as argument at .1. to declarative !.OMP ALLOCATE" }
+
+ !$omp allocators allocate(y) ! { dg-error "28:Unexpected coarray 'y' in 'allocate' at .1." }
+ allocate(y[*])
+
+ !$omp allocate(z) ! { dg-error "17:Unexpected coarray 'z' in 'allocate' at .1." }
+ allocate(z(5)[*])
+ x = 5
+end
+
+
+integer function f() result(res)
+ !$omp allocate(f) ! { dg-error "Argument 'f' at .1. to declarative !.OMP ALLOCATE directive must be a variable" }
+ !$omp allocate(res) ! { dg-error "Unexpected function-result variable 'res' at .1. in declarative !.OMP ALLOCATE" }
+ res = 5
+end
+
+integer function g() result(res)
+ allocatable :: res
+ !$omp allocators allocate(g) ! { dg-error "Expected variable list at .1." }
+
+ !$omp allocators allocate (res)
+ allocate(res, source=5)
+ deallocate(res)
+
+ !$omp allocate (res)
+ allocate(res, source=5)
+end
+
+
+subroutine cray_ptr()
+ real pointee(10)
+ pointer (ipt, pointee)
+ !$omp allocate(pointee) ! { dg-error "Sorry, Cray pointers and pointees such as 'pointee' are not supported with !.OMP ALLOCATE at .1." }
+ !$omp allocate(ipt) ! { dg-error "Sorry, Cray pointers and pointees such as 'ipt' are not supported with !.OMP ALLOCATE at .1." }
+end
+
+subroutine equiv
+ integer :: A
+ real :: B(2)
+ equivalence(A,B)
+ !$omp allocate (A) ! { dg-error "Sorry, EQUIVALENCE object 'a' not supported with !.OMP ALLOCATE at .1." }
+ !$omp allocate (B) ! { dg-error "Sorry, EQUIVALENCE object 'b' not supported with !.OMP ALLOCATE at .1." }
+end
+
+subroutine common
+ use m
+ integer :: a,b,c(5)
+ common /my/ a,b,c
+ !$omp allocate(b) allocator(omp_cgroup_mem_alloc) ! { dg-error "'b' at .1. is part of the common block '/my/' and may only be specificed implicitly via the named common block" }
+end
+
+subroutine c_and_func_ptrs
+ use iso_c_binding
+ implicit none
+ procedure(), pointer :: p
+ type(c_ptr) :: cptr
+ type(c_ptr) :: cfunptr
+
+ !$omp allocate(cptr) ! OK
+ !$omp allocate(cfunptr) ! OK? A normal derived-type var?
+ !$omp allocate(p) ! { dg-error "Argument 'p' at .1. to declarative !.OMP ALLOCATE directive must be a variable" }
+end
diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-15.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-15.f90
new file mode 100644
index 00000000000..a0690a56394
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/allocate-15.f90
@@ -0,0 +1,38 @@
+module m
+use iso_c_binding
+integer, parameter :: omp_allocator_handle_kind = c_intptr_t
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_null_allocator = 0
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_default_mem_alloc = 1
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_large_cap_mem_alloc = 2
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_const_mem_alloc = 3
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_high_bw_mem_alloc = 4
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_low_lat_mem_alloc = 5
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_cgroup_mem_alloc = 6
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_pteam_mem_alloc = 7
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_thread_mem_alloc = 8
+end
+
+subroutine common
+ use m
+ integer :: a,b,c(5)
+ common /my/ a,b,c ! { dg-error "Sorry, !.OMP allocate for COMMON block variable 'my' at .1. not supported" }
+ !$omp allocate(/my/) allocator(omp_cgroup_mem_alloc)
+end
+
+integer function allocators() result(res)
+ use m
+ integer, save :: a(5) = [1,2,3,4,5] ! { dg-error "Sorry, !.OMP allocate for variable 'a' at .1. with SAVE attribute not yet implemented" }
+ !$omp allocate(a) allocator(omp_high_bw_mem_alloc)
+ res = a(4)
+end
+
+
diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90
index a2dcf105ee1..b93a37c780c 100644
--- a/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/allocate-4.f90
@@ -33,13 +33,13 @@ integer(kind=omp_allocator_handle_kind), intent(in) :: my_alloc
!stack variables:
integer :: a,b,c(n),d(5),e(2)
-!$omp allocate(a) ! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" }
+!$omp allocate(a)
!$omp allocate ( b , c ) align ( 32) allocator (my_alloc)
!$omp allocate (d) align( 128 )
!$omp allocate( e ) allocator( omp_high_bw_mem_alloc )
!saved vars
-integer, save :: k,l,m(5),r(2)
+integer, save :: k,l,m(5),r(2) ! { dg-error "Sorry, !.OMP allocate for variable 'k' at .1. with SAVE attribute not yet implemented" }
!$omp allocate(k) align(16) , allocator (omp_large_cap_mem_alloc)
!$omp allocate ( l ) allocator (omp_large_cap_mem_alloc) , align ( 32)
!$omp allocate (m) align( 128 ),allocator( omp_high_bw_mem_alloc )
diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-7.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-7.f90
index b856204d48a..ab85e327795 100644
--- a/gcc/testsuite/gfortran.dg/gomp/allocate-7.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/allocate-7.f90
@@ -47,7 +47,6 @@ integer, pointer :: ptr
integer, parameter :: prm=5
!$omp allocate(prm) align(64) ! { dg-error "Argument 'prm' at .1. to declarative !.OMP ALLOCATE directive must be a variable" }
-! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
!$omp allocate(used) allocator(omp_pteam_mem_alloc) ! { dg-error "Argument 'used' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" }
!$omp allocate(n) allocator(omp_pteam_mem_alloc) ! { dg-error "Unexpected dummy argument 'n' as argument at .1. to declarative !.OMP ALLOCATE" }
@@ -59,7 +58,6 @@ contains
subroutine inner
!$omp allocate(a) allocator(omp_pteam_mem_alloc) ! { dg-error "Argument 'a' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" }
-! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
end
end
@@ -74,7 +72,6 @@ common /com4/ y,z
allocatable :: q
pointer :: b
!$omp allocate (c, d) allocator (omp_pteam_mem_alloc)
-! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
!$omp allocate (/com4/) allocator (omp_pteam_mem_alloc)
!$omp allocate (c) allocator (omp_pteam_mem_alloc) ! { dg-error "Duplicated variable 'c' in !.OMP ALLOCATE" }
!$omp allocate (/com4/) allocator (omp_pteam_mem_alloc) ! { dg-error "Duplicated common block '/com4/' in !.OMP ALLOCATE" }
@@ -86,7 +83,6 @@ end
subroutine four(n)
integer :: qq, rr, ss, tt, uu, vv,n
!$omp allocate (qq) align(3+n) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
-! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
!$omp allocate (rr) align([4]) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
!$omp allocate (ss) align([4]) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
!$omp allocate (tt) align(32.0) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
@@ -99,7 +95,6 @@ subroutine five(n,my_alloc)
integer :: qq, rr, ss, tt, uu, vv,n
integer(omp_allocator_handle_kind) :: my_alloc
!$omp allocate (qq) allocator(3.0) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
-! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
!$omp allocate (rr) allocator(3_2) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Expected integer expression of the 'omp_allocator_handle_kind' kind" }
!$omp allocate (tt) allocator(my_alloc) ! OK
@@ -113,7 +108,6 @@ subroutine five_SaveAll(n,my_alloc)
integer :: qq, rr, ss, tt, uu, vv,n
integer(omp_allocator_handle_kind) :: my_alloc
!$omp allocate (qq) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAVE attribute" }
-! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
!$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAVE attribute" }
!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'ss' at .2. has the SAVE attribute" }
!$omp allocate (tt) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has the SAVE attribute" }
@@ -127,7 +121,6 @@ subroutine five_Save(n,my_alloc)
integer, save :: qq, rr, ss, tt, uu, vv
integer(omp_allocator_handle_kind) :: my_alloc
!$omp allocate (qq) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAVE attribute" }
-! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
!$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAVE attribute" }
!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'ss' at .2. has the SAVE attribute" }
!$omp allocate (tt) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has the SAVE attribute" }
@@ -139,7 +132,6 @@ module five_Module
integer, save :: qq, rr, ss, tt, uu, vv,n
integer(omp_allocator_handle_kind) :: my_alloc
!$omp allocate (qq) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAVE attribute" }
-! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
!$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAVE attribute" }
!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'ss' at .2. has the SAVE attribute" }
!$omp allocate (tt) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has the SAVE attribute" }
@@ -151,7 +143,6 @@ program five_program
integer, save :: qq, rr, ss, tt, uu, vv,n
integer(omp_allocator_handle_kind) :: my_alloc
!$omp allocate (qq) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'qq' at .2. has the SAVE attribute" }
-! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
!$omp allocate (rr) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'rr' at .2. has the SAVE attribute" }
!$omp allocate (ss) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'ss' at .2. has the SAVE attribute" }
!$omp allocate (tt) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'tt' at .2. has the SAVE attribute" }
@@ -170,7 +161,6 @@ subroutine six(n,my_alloc)
integer(omp_allocator_handle_kind) :: my_alloc
!$omp allocate (/com6qq/) allocator(3.0) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item '/com6qq/' at .2. has the SAVE attribute" }
-! { dg-error "Sorry, declarative !.OMP ALLOCATE at .1. not yet supported" "" { target *-*-* } .-1 }
!$omp allocate (/com6rr/) allocator(3_2) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item '/com6rr/' at .2. has the SAVE attribute" }
!$omp allocate (/com6ss/) allocator([omp_pteam_mem_alloc]) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item '/com6ss/' at .2. has the SAVE attribute" }
!$omp allocate (/com6tt/) allocator(my_alloc) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item '/com6tt/' at .2. has the SAVE attribute" }
diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-8.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-8.f90
new file mode 100644
index 00000000000..bb4d07d0c73
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/allocate-8.f90
@@ -0,0 +1,29 @@
+! { dg-additional-options "-fdump-tree-original" }
+
+module m
+ use iso_c_binding
+ !use omp_lib, only: omp_allocator_handle_kind
+ implicit none
+ integer, parameter :: omp_allocator_handle_kind = c_intptr_t
+ integer :: a = 0, b = 42, c = 0
+
+contains
+ integer(omp_allocator_handle_kind) function get_alloc()
+ allocatable :: get_alloc
+ get_alloc = 2_omp_allocator_handle_kind
+ end
+ subroutine foo ()
+ !$omp scope private (a) firstprivate (b) reduction (+: c) allocate ( get_alloc() : a , b , c)
+ if (b /= 42) &
+ error stop
+ a = 36
+ b = 15
+ c = c + 1
+ !$omp end scope
+ end
+end
+
+! { dg-final { scan-tree-dump "omp scope private\\(a\\) firstprivate\\(b\\) reduction\\(\\+:c\\) allocate\\(allocator\\(D\\.\[0-9\]+\\):a\\) allocate\\(allocator\\(D\\.\[0-9\]+\\):b\\) allocate\\(allocator\\(D\\.\[0-9\]+\\):c\\)" "original" } }
+
+! { dg-final { scan-tree-dump-times "D\\.\[0-9\]+ = get_alloc \\(\\);\[\n\r\]+ *D\\.\[0-9\]+ = \\*D\\.\[0-9\]+;\[\n\r\]+ *__builtin_free \\(\\(void \\*\\) D\\.\[0-9\]+\\);" 1 "original" } }
+
diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-9.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-9.f90
new file mode 100644
index 00000000000..4d9553686c4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/allocate-9.f90
@@ -0,0 +1,112 @@
+module m
+use iso_c_binding
+integer, parameter :: omp_allocator_handle_kind = c_intptr_t
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_null_allocator = 0
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_default_mem_alloc = 1
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_large_cap_mem_alloc = 2
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_const_mem_alloc = 3
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_high_bw_mem_alloc = 4
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_low_lat_mem_alloc = 5
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_cgroup_mem_alloc = 6
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_pteam_mem_alloc = 7
+ integer (kind=omp_allocator_handle_kind), &
+ parameter :: omp_thread_mem_alloc = 8
+end
+
+
+module m2
+ use m
+ implicit none
+ integer :: A(5) = [1,2,3,4,5], A2, A3, A4, A5
+ integer :: B, C, D
+
+! If the following fails because of added predefined allocators, please update
+! - c/c-parser.c's c_parser_omp_allocate
+! - fortran/openmp.cc's is_predefined_allocator
+! - libgomp/env.c's parse_allocator
+! - libgomp/libgomp.texi (document the new values - multiple locations)
+! + ensure that the memory-spaces are also up to date.
+
+!$omp allocate(A) align(32) allocator(9_omp_allocator_handle_kind) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'a' at .2. has the SAVE attribute" }
+
+! typo in allocator name:
+!$omp allocate(A2) allocator(omp_low_latency_mem_alloc) ! { dg-error "Symbol 'omp_low_latency_mem_alloc' at .1. has no IMPLICIT type; did you mean 'omp_low_lat_mem_alloc'\\?" }
+! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'a2' at .2. has the SAVE attribute" "" { target *-*-* } .-1 }
+
+! align be const multiple of 2
+!$omp allocate(A3) align(31) allocator(omp_default_mem_alloc) ! { dg-error "ALIGN requires a scalar positive constant integer alignment expression at .1. that is a power of two" }
+
+! allocator missing (required as A is static)
+!$omp allocate(A4) align(32) ! { dg-error "An ALLOCATOR clause is required as the list item 'a4' at .1. has the SAVE attribute" }
+
+! "expression in the clause must be a constant expression that evaluates to one of the
+! predefined memory allocator values -> omp_low_lat_mem_alloc"
+!$omp allocate(B) allocator(omp_high_bw_mem_alloc+1_omp_allocator_handle_kind) align(32) ! OK: omp_low_lat_mem_alloc
+
+!$omp allocate(C) allocator(2_omp_allocator_handle_kind) ! OK: omp_large_cap_mem_alloc
+
+!$omp allocate(A5) align(32) allocator(omp_null_allocator) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'a5' at .2. has the SAVE attribute" }
+
+!$omp allocate(C) align(32) allocator(omp_large_cap_mem_alloc) ! { dg-error "Duplicated variable 'c' in !.OMP ALLOCATE at .1." }
+
+contains
+
+integer function f()
+ !$omp allocate(D) align(32) allocator(omp_large_cap_mem_alloc) ! { dg-error "Argument 'd' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" }
+ f = A(1)
+end
+
+integer function g()
+ integer :: a2, b2
+ !$omp allocate(a2)
+ !$omp allocate(a2) ! { dg-error "Duplicated variable 'a2' in !.OMP ALLOCATE at .1." }
+ a2=1; b2=2
+ block
+ integer :: c2
+ !$omp allocate(c2, b2) ! { dg-error "Argument 'b2' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" }
+ c2 = 3
+ g = c2+a2+b2
+ end block
+end
+
+integer function h(q)
+ integer :: q
+ !$omp allocate(q) ! { dg-error "Unexpected dummy argument 'q' as argument at .1. to declarative !.OMP ALLOCATE" }
+ h = q
+end
+
+integer function k ()
+ integer, save :: var3 = 8
+ !$omp allocate(var3) allocator(-1_omp_allocator_handle_kind) ! { dg-error "Predefined allocator required in ALLOCATOR clause at .1. as the list item 'var3' at .2. has the SAVE attribute" }
+ k = var3
+end
+end module
+
+
+subroutine foo
+ integer :: a, b
+ integer :: c, d,h
+ !$omp allocate(a,b)
+ b = 1; d = 5
+contains
+subroutine internal
+ integer :: e,f
+ !$omp allocate(c,d)
+ ! { dg-error "Argument 'c' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" "" { target *-*-* } .-1 }
+ ! { dg-error "Argument 'd' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" "" { target *-*-* } .-2 }
+ !$omp allocate(e)
+ a = 1; c = 2; e = 4
+ block
+ !$omp allocate(f) ! { dg-error "Argument 'f' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" }
+ !$omp allocate(h) ! { dg-error "Argument 'h' at .1. to declarative !.OMP ALLOCATE shall be in the same scope as the variable declaration" }
+ end block
+end
+end
diff --git a/libgomp/libgomp.texi b/libgomp/libgomp.texi
index ba8e9013814..0d965f96d48 100644
--- a/libgomp/libgomp.texi
+++ b/libgomp/libgomp.texi
@@ -225,7 +225,7 @@ The OpenMP 4.5 specification is fully supported.
@item Predefined memory spaces, memory allocators, allocator traits
@tab Y @tab See also @ref{Memory allocation}
@item Memory management routines @tab Y @tab
-@item @code{allocate} directive @tab P @tab Only C, only stack variables
+@item @code{allocate} directive @tab P @tab Only C and Fortran, only stack variables
@item @code{allocate} clause @tab P @tab Initial support
@item @code{use_device_addr} clause on @code{target data} @tab Y @tab
@item @code{ancestor} modifier on @code{device} clause @tab Y @tab
@@ -297,7 +297,7 @@ The OpenMP 4.5 specification is fully supported.
@item @code{strict} modifier in the @code{grainsize} and @code{num_tasks}
clauses of the @code{taskloop} construct @tab Y @tab
@item @code{align} clause in @code{allocate} directive @tab P
- @tab Only C (and only stack variables)
+ @tab Only C and Fortran (and only stack variables)
@item @code{align} modifier in @code{allocate} clause @tab Y @tab
@item @code{thread_limit} clause to @code{target} construct @tab Y @tab
@item @code{has_device_addr} clause to @code{target} construct @tab Y @tab
diff --git a/libgomp/testsuite/libgomp.fortran/allocate-5.f90 b/libgomp/testsuite/libgomp.fortran/allocate-5.f90
new file mode 100644
index 00000000000..de9cd5a302e
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/allocate-5.f90
@@ -0,0 +1,87 @@
+! { dg-additional-options "-fdump-tree-gimple" }
+
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_alloc \\(" 5 "gimple" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(" 5 "gimple" } }
+
+
+module m
+ use omp_lib
+ use iso_c_binding
+ implicit none (type, external)
+ integer(c_intptr_t) :: intptr
+contains
+
+integer function one ()
+ integer :: sum, i
+ !$omp allocate(sum)
+ ! { dg-final { scan-tree-dump-times "sum\\.\[0-9\]+ = __builtin_GOMP_alloc \\(4, 4, 0B\\);" 1 "gimple" } }
+ ! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(sum\\.\[0-9\]+, 0B\\);" 1 "gimple" } }
+
+ ! NOTE: Initializer cannot be omp_init_allocator - as 'A' is
+ ! in the same scope and the auto-omp_free comes later than
+ ! any omp_destroy_allocator.
+ integer(omp_allocator_handle_kind) :: my_allocator = omp_low_lat_mem_alloc
+ integer :: n = 25
+ sum = 0
+ block
+ type(omp_alloctrait) :: traits(1) = [ omp_alloctrait(omp_atk_alignment, 64) ]
+ integer :: A(n)
+ !$omp allocate(A) align(128) allocator(my_allocator)
+ ! { dg-final { scan-tree-dump-times "a = __builtin_GOMP_alloc \\(128, D\\.\[0-9\]+, D\\.\[0-9\]+\\);" 1 "gimple" } }
+ ! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(a, 0B\\);" 1 "gimple" } }
+
+ if (mod (transfer(loc(A), intptr), 128_c_intptr_t) /= 0) &
+ stop 2
+ do i = 1, n
+ A(i) = i
+ end do
+
+ my_allocator = omp_init_allocator(omp_low_lat_mem_space,1,traits)
+ block
+ integer B(n)
+ integer C(5)
+ !$omp allocate(B,C) allocator(my_allocator)
+ ! { dg-final { scan-tree-dump-times "b = __builtin_GOMP_alloc \\(\[0-9\]+, D\\.\[0-9\]+, D\\.\[0-9\]+\\);" 1 "gimple" } }
+ ! { dg-final { scan-tree-dump-times "c\\.\[0-9\]+ = __builtin_GOMP_alloc \\(\[0-9\]+, 20, D\\.\[0-9\]+\\);" 1 "gimple" } }
+ ! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(b, 0B\\);" 1 "gimple" } }
+ ! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(c\\.\[0-9\]+, 0B\\);" 1 "gimple" } }
+
+ integer :: D(5)
+ !$omp allocate(D) align(256)
+ ! { dg-final { scan-tree-dump-times "d\\.\[0-9\]+ = __builtin_GOMP_alloc \\(256, 20, 0B\\);" 1 "gimple" } }
+ ! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(d\\.\[0-9\]+, 0B\\);" 1 "gimple" } }
+
+ B = 0
+ C = [1,2,3,4,5]
+ D = [11,22,33,44,55]
+
+ if (mod (transfer(loc(B), intptr), 64_c_intptr_t) /= 0) &
+ stop 3
+ if (mod (transfer(loc(C), intptr), 64_c_intptr_t) /= 0) &
+ stop 4
+ if (mod (transfer(loc(D), intptr), 256_c_intptr_t) /= 0) &
+ stop 5
+
+ do i = 1, 5
+ if (C(i) /= i) &
+ stop 6
+ if (D(i) /= i + 10*i) &
+ stop 7
+ end do
+
+ do i = 1, n
+ if (B(i) /= 0) &
+ stop 9
+ sum = sum + A(i)+B(i)+C(mod(i,5)+1)+D(mod(i,5)+1)
+ end do
+ end block
+ call omp_destroy_allocator (my_allocator)
+ end block
+ one = sum
+end
+end module
+
+use m
+if (one () /= 1225) &
+ stop 1
+end
diff --git a/libgomp/testsuite/libgomp.fortran/allocate-6.f90 b/libgomp/testsuite/libgomp.fortran/allocate-6.f90
new file mode 100644
index 00000000000..5c32652f2a6
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/allocate-6.f90
@@ -0,0 +1,123 @@
+module m
+ use iso_c_binding
+ use omp_lib
+ implicit none (type, external)
+ integer(c_intptr_t) :: intptr
+
+! { dg-final { scan-tree-dump-not "__builtin_stack_save" "gimple" } }
+! { dg-final { scan-tree-dump-not "__builtin_alloca" "gimple" } }
+! { dg-final { scan-tree-dump-not "__builtin_stack_restore" "gimple" } }
+
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_alloc \\(" 5 "gimple" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(" 5 "gimple" } }
+
+contains
+
+subroutine one ()
+ integer :: result, n, i
+ result = 0
+ n = 3
+ !$omp target map(tofrom: result) firstprivate(n)
+ block
+ integer :: var, var2(n)
+ !$omp allocate(var,var2) align(128) allocator(omp_low_lat_mem_alloc)
+ var = 5
+! { dg-final { scan-tree-dump-times "var\\.\[0-9\]+ = __builtin_GOMP_alloc \\(128, 4, 5\\);" 1 "gimple" } } */
+! { dg-final { scan-tree-dump-times "var2\\.\[0-9\]+ = __builtin_GOMP_alloc \\(128, D\\.\[0-9\]+, 5\\);" 1 "gimple" } } */
+
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(var\\.\[0-9\]+, 0B\\);" 1 "gimple" } } */
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(var2\\.\[0-9\]+, 0B\\);" 1 "gimple" } } */
+
+ if (mod(transfer(loc(var), intptr), 128_c_intptr_t) /= 0) &
+ stop 1
+ if (mod(transfer(loc(var2), intptr), 128_c_intptr_t) /= 0) &
+ stop 2
+ if (var /= 5) &
+ stop 3
+
+ !$omp parallel do
+ do i = 1, n
+ var2(i) = (i+32);
+ end do
+
+ !$omp parallel loop reduction(+:result)
+ do i = 1, n
+ result = result + var + var2(i)
+ end do
+ end block
+ if (result /= (3*5 + 33 + 34 + 35)) &
+ stop 4
+end
+
+subroutine two ()
+ type st
+ integer :: a, b
+ end type
+ integer :: scalar, array(5), i
+ type(st) s
+ !$omp allocate(scalar, array, s)
+! { dg-final { scan-tree-dump-times "scalar\\.\[0-9\]+ = __builtin_GOMP_alloc \\(4, 4, 0B\\);" 1 "gimple" } }
+! { dg-final { scan-tree-dump-times "array\\.\[0-9\]+ = __builtin_GOMP_alloc \\(4, 20, 0B\\);" 1 "gimple" } }
+! { dg-final { scan-tree-dump-times "s\\.\[0-9\]+ = __builtin_GOMP_alloc \\(4, 8, 0B\\);" 1 "gimple" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(scalar\\.\[0-9\]+, 0B\\);" 1 "gimple" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(array\\.\[0-9\]+, 0B\\);" 1 "gimple" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(s\\.\[0-9\]+, 0B\\);" 1 "gimple" } }
+
+ scalar = 44
+ array = [1,2,3,4,5]
+ s = st(a=11, b=56)
+
+ !$omp parallel firstprivate(scalar) firstprivate(array) firstprivate(s)
+ if (scalar /= 44) &
+ stop 5
+ scalar = 33;
+ if (any (array /= [1,2,3,4,5])) &
+ stop 6
+ array = [10,20,30,40,50]
+ if (s%a /= 11 .or. s%b /= 56) &
+ stop 7
+ s%a = 74
+ s%b = 674
+ !$omp end parallel
+
+ if (scalar /= 44) &
+ stop 8
+ if (any (array /= [1,2,3,4,5])) &
+ stop 9
+ if (s%a /= 11 .or. s%b /= 56) &
+ stop 10
+
+ !$omp target defaultmap(firstprivate : scalar) defaultmap(none : aggregate) defaultmap(none : pointer)
+ if (scalar /= 44) &
+ stop 11
+ scalar = 33;
+ !$omp end target
+
+ if (scalar /= 44) &
+ stop 12
+
+ !$omp target defaultmap(none : scalar) defaultmap(firstprivate : aggregate) defaultmap(none : pointer) private(i)
+ if (any (array /= [1,2,3,4,5])) &
+ stop 13
+ do i = 1, 5
+ array(i) = 10*i
+ end do
+ !$omp end target
+
+ if (any(array /= [1,2,3,4,5])) &
+ stop 13
+ !$omp target defaultmap(none : scalar) defaultmap(firstprivate : aggregate) defaultmap(none : pointer)
+ if (s%a /= 11 .or. s%b /= 56) &
+ stop 14
+ s%a = 74
+ s%b = 674
+ !$omp end target
+ if (s%a /= 11 .or. s%b /= 56) &
+ stop 15
+end
+end module
+
+use m
+ call one ()
+ call two ()
+end
diff --git a/libgomp/testsuite/libgomp.fortran/allocate-7.f90 b/libgomp/testsuite/libgomp.fortran/allocate-7.f90
new file mode 100644
index 00000000000..4a0f6b6df32
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/allocate-7.f90
@@ -0,0 +1,342 @@
+! { dg-additional-options "-fdump-tree-omplower" }
+
+! For the 4 vars in omp_parallel, 4 in omp_target and 1 of 2 in no_alloc2_func.
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_alloc \\(" 9 "omplower" } }
+! { dg-final { scan-tree-dump-times "__builtin_GOMP_free \\(" 9 "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
diff --git a/libgomp/testsuite/libgomp.fortran/allocate-8.f90 b/libgomp/testsuite/libgomp.fortran/allocate-8.f90
new file mode 100644
index 00000000000..b9dea6c5148
--- /dev/null
+++ b/libgomp/testsuite/libgomp.fortran/allocate-8.f90
@@ -0,0 +1,99 @@
+module m
+use omp_lib
+implicit none
+!!$omp requires dynamic_allocators
+
+integer :: final_count
+
+type t
+ integer :: i = 0
+ integer, allocatable :: A(:,:)
+contains
+ final :: count_finalization
+end type t
+
+contains
+
+elemental impure subroutine count_finalization(self)
+ type(t), intent(in) :: self
+ final_count = final_count + 1
+end
+
+subroutine test(allocator)
+integer(omp_allocator_handle_kind), optional, value :: allocator
+call zero_size(allocator)
+call finalization_test(allocator)
+end subroutine test
+
+subroutine finalization_test(allocator)
+integer(omp_allocator_handle_kind), optional, value :: allocator
+integer :: n = 5
+
+final_count = 0;
+block
+ type(t) :: A
+! !$omp allocate(A) allocator(allocator)
+ A%i = 1
+end block
+if (final_count /= 1) &
+ stop 10
+
+final_count = 0;
+block
+ type(t) :: B(7)
+ !$omp allocate(B) allocator(allocator)
+ B(1)%i = 1
+end block
+if (final_count /= 7) stop 10
+
+final_count = 0;
+block
+ type(t) :: C(n)
+! !$omp allocate(C) allocator(allocator)
+ C(1)%i = 1
+end block
+if (final_count /= 5) stop 10
+
+final_count = 0;
+block
+ type(t) :: D(0)
+! !$omp allocate(D) allocator(allocator)
+ D(1:0)%i = 1
+end block
+if (final_count /= 0) stop 10
+end subroutine
+
+subroutine zero_size(allocator)
+integer(omp_allocator_handle_kind), optional, value :: allocator
+integer :: n
+n = -3
+
+block
+ integer :: A(n)
+ character(len=n) :: B
+! !$omp allocate(A,b) allocator(allocator)
+ if (size(A) /= 0 .or. len(b) /= 0) &
+ stop 1
+ B(1:len(b)) ='A'
+end block
+
+!!$omp target
+block
+ integer :: A(n)
+ character(len=n) :: B
+! !$omp allocate(A,b) allocator(allocator)
+ if (size(A) /= 0 .or. len(b) /= 0) &
+ stop 2
+ B(1:len(b)) ='A'
+end block
+end
+end module
+
+use m
+call test()
+call test(omp_default_mem_alloc)
+call test(omp_large_cap_mem_alloc)
+call test(omp_high_bw_mem_alloc)
+call test(omp_low_lat_mem_alloc)
+call test(omp_cgroup_mem_alloc)
+end
next reply other threads:[~2023-10-10 16:46 UTC|newest]
Thread overview: 7+ messages / expand[flat|nested] mbox.gz Atom feed top
2023-10-10 16:46 Tobias Burnus [this message]
2023-10-13 11:01 ` Jakub Jelinek
2023-10-13 13:29 ` Tobias Burnus
2023-10-18 9:12 ` Thomas Schwinge
2023-10-18 9:36 ` Jakub Jelinek
2023-10-18 10:56 ` [Patch] OpenMP: Avoid ICE with LTO and 'omp allocate (was: [Patch] Fortran: Support OpenMP's 'allocate' directive for stack vars) Tobias Burnus
2023-10-18 11:01 ` Jakub Jelinek
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=457ea120-5cca-48e0-89d6-c3eab4234b61@codesourcery.com \
--to=tobias@codesourcery.com \
--cc=fortran@gcc.gnu.org \
--cc=gcc-patches@gcc.gnu.org \
--cc=jakub@redhat.com \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).