diff --git a/gcc/omp-low.cc b/gcc/omp-low.cc index cdadd6f0c96..7d1a2a0d795 100644 --- a/gcc/omp-low.cc +++ b/gcc/omp-low.cc @@ -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 (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 (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), "% 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 (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 (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 (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); diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-6.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-6.f90 index 6957bc55da0..738d9936f6a 100644 --- a/gcc/testsuite/gfortran.dg/gomp/allocate-6.f90 +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-6.f90 @@ -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" } } diff --git a/gcc/testsuite/gfortran.dg/gomp/allocate-7.f90 b/gcc/testsuite/gfortran.dg/gomp/allocate-7.f90 new file mode 100644 index 00000000000..db76e901c08 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-7.f90 @@ -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 + 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..699a3b80878 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gomp/allocate-8.f90 @@ -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 + diff --git a/libgomp/testsuite/libgomp.fortran/allocate-2.f90 b/libgomp/testsuite/libgomp.fortran/allocate-2.f90 new file mode 100644 index 00000000000..2219f107fe7 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/allocate-2.f90 @@ -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