@@ -1746,6 +1746,7 @@ scan_sharing_clauses (tree clauses, omp_context *ctx)
case OMP_CLAUSE_FINALIZE:
case OMP_CLAUSE_TASK_REDUCTION:
case OMP_CLAUSE_ALLOCATE:
+ case OMP_CLAUSE_ALLOCATOR:
break;
case OMP_CLAUSE_ALIGNED:
@@ -1963,6 +1964,7 @@ scan_sharing_clauses (tree clauses, omp_context *ctx)
case OMP_CLAUSE_FINALIZE:
case OMP_CLAUSE_FILTER:
case OMP_CLAUSE__CONDTEMP_:
+ case OMP_CLAUSE_ALLOCATOR:
break;
case OMP_CLAUSE__CACHE_:
@@ -3033,6 +3035,16 @@ scan_omp_simd_scan (gimple_stmt_iterator *gsi, gomp_for *stmt,
maybe_lookup_ctx (new_stmt)->for_simd_scan_phase = true;
}
+/* Scan an OpenMP allocate directive. */
+
+static void
+scan_omp_allocate (gomp_allocate *stmt, omp_context *outer_ctx)
+{
+ omp_context *ctx;
+ ctx = new_omp_context (stmt, outer_ctx);
+ scan_sharing_clauses (gimple_omp_allocate_clauses (stmt), ctx);
+}
+
/* Scan an OpenMP sections directive. */
static void
@@ -4332,6 +4344,9 @@ scan_omp_1_stmt (gimple_stmt_iterator *gsi, bool *handled_ops_p,
insert_decl_map (&ctx->cb, var, var);
}
break;
+ case GIMPLE_OMP_ALLOCATE:
+ scan_omp_allocate (as_a <gomp_allocate *> (stmt), ctx);
+ break;
default:
*handled_ops_p = false;
break;
@@ -8768,6 +8783,125 @@ lower_omp_single_simple (gomp_single *single_stmt, gimple_seq *pre_p)
gimple_seq_add_stmt (pre_p, gimple_build_label (flabel));
}
+static void
+lower_omp_allocate (gimple_stmt_iterator *gsi_p, omp_context *ctx)
+{
+ gomp_allocate *st = as_a <gomp_allocate *> (gsi_stmt (*gsi_p));
+ tree clauses = gimple_omp_allocate_clauses (st);
+ int kind = gimple_omp_allocate_kind (st);
+ gcc_assert (kind == GF_OMP_ALLOCATE_KIND_ALLOCATE
+ || kind == GF_OMP_ALLOCATE_KIND_FREE);
+
+ for (tree c = clauses; c; c = OMP_CLAUSE_CHAIN (c))
+ {
+ if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_ALLOCATOR)
+ continue;
+
+ bool allocate = (kind == GF_OMP_ALLOCATE_KIND_ALLOCATE);
+ /* The allocate directives that appear in a target region must specify
+ an allocator clause unless a requires directive with the
+ dynamic_allocators clause is present in the same compilation unit. */
+ if (OMP_ALLOCATE_ALLOCATOR (c) == NULL_TREE
+ && ((omp_requires_mask & OMP_REQUIRES_DYNAMIC_ALLOCATORS) == 0)
+ && omp_maybe_offloaded_ctx (ctx))
+ error_at (OMP_CLAUSE_LOCATION (c), "%<allocate%> directive must"
+ " specify an allocator here");
+
+ tree var = OMP_ALLOCATE_DECL (c);
+
+ gimple_stmt_iterator gsi = *gsi_p;
+ for (gsi_next (&gsi); !gsi_end_p (gsi); gsi_next (&gsi))
+ {
+ gimple *stmt = gsi_stmt (gsi);
+
+ if (gimple_code (stmt) != GIMPLE_CALL
+ || (allocate && gimple_call_fndecl (stmt)
+ != builtin_decl_explicit (BUILT_IN_MALLOC))
+ || (!allocate && gimple_call_fndecl (stmt)
+ != builtin_decl_explicit (BUILT_IN_FREE)))
+ continue;
+ const gcall *gs = as_a <const gcall *> (stmt);
+ tree allocator = OMP_ALLOCATE_ALLOCATOR (c)
+ ? OMP_ALLOCATE_ALLOCATOR (c)
+ : integer_zero_node;
+ if (allocate)
+ {
+ tree lhs = gimple_call_lhs (gs);
+ if (lhs && TREE_CODE (lhs) == SSA_NAME)
+ {
+ gimple_stmt_iterator gsi2 = gsi;
+ gsi_next (&gsi2);
+ gimple *assign = gsi_stmt (gsi2);
+ if (gimple_code (assign) == GIMPLE_ASSIGN)
+ {
+ lhs = gimple_assign_lhs (as_a <const gassign *> (assign));
+ if (lhs == NULL_TREE
+ || TREE_CODE (lhs) != COMPONENT_REF)
+ continue;
+ lhs = TREE_OPERAND (lhs, 0);
+ }
+ }
+
+ if (lhs == var)
+ {
+ unsigned HOST_WIDE_INT ialign = 0;
+ tree align;
+ if (TYPE_P (var))
+ ialign = TYPE_ALIGN_UNIT (var);
+ else
+ ialign = DECL_ALIGN_UNIT (var);
+ align = build_int_cst (size_type_node, ialign);
+ tree repl = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC);
+ tree size = gimple_call_arg (gs, 0);
+ gimple *g = gimple_build_call (repl, 3, align, size,
+ allocator);
+ gimple_call_set_lhs (g, gimple_call_lhs (gs));
+ gimple_set_location (g, gimple_location (stmt));
+ gsi_replace (&gsi, g, true);
+ /* The malloc call has been replaced. Now see if there is
+ any free call due to deallocate statement and replace
+ that too. */
+ allocate = false;
+ }
+ }
+ else
+ {
+ tree arg = gimple_call_arg (gs, 0);
+ if (arg && TREE_CODE (arg) == SSA_NAME)
+ {
+ gimple_stmt_iterator gsi2 = gsi;
+ gsi_prev (&gsi2);
+ if (!gsi_end_p (gsi2))
+ {
+ gimple *gs = gsi_stmt (gsi2);
+ if (gimple_code (gs) == GIMPLE_ASSIGN)
+ {
+ const gassign *assign = as_a <const gassign *> (gs);
+ tree rhs = gimple_assign_rhs1 (assign);
+ tree lhs = gimple_assign_lhs (assign);
+ if (lhs == arg && rhs
+ && TREE_CODE (rhs) == COMPONENT_REF)
+ arg = TREE_OPERAND (rhs, 0);
+ }
+ }
+ }
+
+ if (arg == var)
+ {
+ tree repl = builtin_decl_explicit (BUILT_IN_GOMP_FREE);
+ gimple *g = gimple_build_call (repl, 2,
+ gimple_call_arg (gs, 0),
+ allocator);
+ gimple_set_location (g, gimple_location (stmt));
+ gsi_replace (&gsi, g, true);
+ break;
+ }
+ }
+ }
+ }
+ gsi_replace (gsi_p, gimple_build_nop (), true);
+}
+
/* A subroutine of lower_omp_single. Expand the simple form of
a GIMPLE_OMP_SINGLE, with a copyprivate clause:
@@ -14431,6 +14565,11 @@ lower_omp_1 (gimple_stmt_iterator *gsi_p, omp_context *ctx)
gcc_assert (ctx);
lower_omp_scope (gsi_p, ctx);
break;
+ case GIMPLE_OMP_ALLOCATE:
+ ctx = maybe_lookup_ctx (stmt);
+ gcc_assert (ctx);
+ lower_omp_allocate (gsi_p, ctx);
+ break;
case GIMPLE_OMP_SINGLE:
ctx = maybe_lookup_ctx (stmt);
gcc_assert (ctx);
@@ -1,5 +1,6 @@
! { dg-do compile }
! { dg-additional-options "-fdump-tree-original -fdump-tree-gimple" }
+! { dg-additional-options "-fdump-tree-omplower" }
module omp_lib_kinds
use iso_c_binding, only: c_int, c_intptr_t
@@ -47,6 +48,7 @@ end type
real, allocatable :: var3(:,:)
type (my_type), allocatable :: var4
integer, pointer :: pii, parr(:)
+ integer, allocatable :: var
character, allocatable :: str1a, str1aarr(:)
character(len=5), allocatable :: str5a, str5aarr(:)
@@ -67,9 +69,16 @@ end type
!$omp allocate
allocate(pii, parr(5))
+
+ ! allocate statement not associated with an allocate directive
+ allocate(var)
end subroutine
! { dg-final { scan-tree-dump-times "#pragma omp allocate \\(kind=allocate\\)" 6 "original" } }
! { dg-final { scan-tree-dump "#pragma omp allocate \\(kind=free\\)" "original" } }
! { dg-final { scan-tree-dump-times "#pragma omp allocate \\(kind=allocate\\)" 6 "gimple" } }
! { dg-final { scan-tree-dump "#pragma omp allocate \\(kind=free\\)" "gimple" } }
+! { dg-final { scan-tree-dump-times "builtin_malloc" 11 "original" } }
+! { dg-final { scan-tree-dump-times "builtin_free" 9 "original" } }
+! { dg-final { scan-tree-dump-times "GOMP_alloc" 10 "omplower" } }
+! { dg-final { scan-tree-dump-times "GOMP_free" 8 "omplower" } }
new file mode 100644
@@ -0,0 +1,13 @@
+! { dg-do compile }
+
+subroutine bar(a)
+ implicit none
+ integer :: a
+ integer, allocatable :: var
+!$omp target
+ !$omp allocate (var) ! { dg-error "'allocate' directive must specify an allocator here" }
+ allocate (var)
+!$omp end target
+
+end subroutine
+
new file mode 100644
@@ -0,0 +1,15 @@
+! { dg-do compile }
+
+
+subroutine bar(a)
+ implicit none
+ integer :: a
+ integer, allocatable :: var
+!$omp requires dynamic_allocators
+!$omp target
+ !$omp allocate (var)
+ allocate (var)
+!$omp end target
+
+end subroutine
+
new file mode 100644
@@ -0,0 +1,48 @@
+! { dg-do run }
+! { dg-additional-sources allocate-1.c }
+! { dg-prune-output "command-line option '-fintrinsic-modules-path=.*' is valid for Fortran but not for C" }
+
+module m
+ use omp_lib
+ use iso_c_binding
+ implicit none
+ interface
+ integer(c_int) function is_64bit_aligned (a) bind(C)
+ import :: c_int
+ integer :: a
+ end
+ end interface
+
+contains
+
+subroutine foo (x, y, h)
+ use omp_lib
+ integer :: x
+ integer :: y
+ integer (kind=omp_allocator_handle_kind) :: h
+ integer, allocatable :: var1
+
+ !$omp allocate (var1) allocator(h)
+ allocate (var1)
+
+ if (is_64bit_aligned(var1) == 0) then
+ stop 19
+ end if
+
+ deallocate(var1)
+end subroutine
+end module m
+
+program main
+ use omp_lib
+ use m
+ type (omp_alloctrait) :: traits(2)
+ integer (omp_allocator_handle_kind) :: a
+
+ traits = [omp_alloctrait (omp_atk_alignment, 64), &
+ omp_alloctrait (omp_atk_fallback, omp_atv_null_fb)]
+ a = omp_init_allocator (omp_default_mem_space, 2, traits)
+ if (a == omp_null_allocator) stop 1
+ call foo (42, 12, a);
+ call omp_destroy_allocator (a);
+end