Hi!
I'm currently reviewing 'gomp_copy_host2dev', 'ephemeral' in a different
context, and a question came up here;
commit r13-706-g49d1a2f91325fa8cc011149e27e5093a988b3a49
"OpenMP: Handle descriptors in target's firstprivate [PR104949]":
On 2022-05-11T19:33:00+0200, Tobias Burnus <tobias@codesourcery.com> wrote:
> this patch handles (for target regions)
> firstprivate(array_descriptor)
> by not only firstprivatizing the descriptor but also the data
> it points to. This is done by turning it in omp-low.cc the clause
> into
> firstprivate(descr) firstprivate(descr.data)
> and then attaching the latter to the former. That works by
> adding an 'attach' after the last firstprivate (and checking
> for it in libgomp). The attached-to device address for a
> previous (here: the first) firstprivate is obtained by returning
> the device address inside the hostaddrs[i] alias omp_arr array,
> i.e. the compiler generates:
> omp_arr.1 = &descr; /* firstprivate */
> omp_arr.2 = descr.data; /* firstprivate */
> omp_arr.3 = &omp_arr.1; /* attach; bias: &desc.data-&desc */
> and libgomp then knows that the device address is in the
> pointer.
> Note: The code is not active for OpenACC. The existing code uses, e.g.,
> 'goto oacc_firstprivate' – thus, the new code would be
> partially active. I went for making it completely inactive for OpenACC
> by adding one '!is_gimple_omp_oacc'.
ACK.
> I bet that a deep copy would be
> also useful for OpenACC, but I have neither checked what the current
> code does nor what the OpenACC spec says about this.
Instead of adding corresponding handling to the OpenACC 'firstprivate'
special code paths later on, I suggest that we first address known issues
with OpenACC 'firstprivate' -- which probably may largely be achieved by
in fact removing those 'goto oacc_firstprivate's and other special code
paths? For example, see <https://gcc.gnu.org/PR92036>
"OpenACC 'firstprivate' clause: initial value".
That means, the following code currently isn't active for OpenACC, and
given that OpenMP 'target' doesn't do asynchronous device execution
(meaning: not in the way/implementation of OpenACC 'async'), it thus
doesn't care about the 'ephemeral' argument to 'gomp_copy_host2dev', but
still, for correctness (and once that code gets used for OpenACC):
> OpenMP: Handle descriptors in target's firstprivate [PR104949]
>
> For allocatable/pointer arrays, a firstprivate to a device
> not only needs to privatize the descriptor but also the actual
> data. This is implemented as:
> firstprivate(x) firstprivate(x.data) attach(x [bias: &x.data-&x)
> where the address of x in device memory is saved in hostaddrs[i]
> by libgomp and the middle end actually passes hostaddrs[i]' to
> attach.
> --- a/libgomp/target.c
> +++ b/libgomp/target.c
> @@ -1350,7 +1350,24 @@ gomp_map_vars_internal (struct gomp_device_descr *devicep,
> gomp_copy_host2dev (devicep, aq,
> (void *) (tgt->tgt_start + tgt_size),
> (void *) hostaddrs[i], len, false, cbufp);
Here, passing 'ephemeral <- false' is correct, as 'h <- hostaddrs[i]'
points to non-ephemeral data.
> + /* Save device address in hostaddr to permit latter availablity
> + when doing a deep-firstprivate with pointer attach. */
> + hostaddrs[i] = (void *) (tgt->tgt_start + tgt_size);
Here, we modify 'hostaddrs[i]' (itself -- *not* the data that the
original 'hostaddrs[i]' points to), so the above 'gomp_copy_host2dev'
with 'ephemeral <- false' is still correct, right?
> tgt_size += len;
> +
> + /* If followed by GOMP_MAP_ATTACH, pointer assign this
> + firstprivate to hostaddrs[i+1], which is assumed to contain a
> + device address. */
> + if (i + 1 < mapnum
> + && (GOMP_MAP_ATTACH
> + == (typemask & get_kind (short_mapkind, kinds, i+1))))
> + {
> + uintptr_t target = (uintptr_t) hostaddrs[i];
> + void *devptr = *(void**) hostaddrs[i+1] + sizes[i+1];
> + gomp_copy_host2dev (devicep, aq, devptr, &target,
> + sizeof (void *), false, cbufp);
However, 'h <- &target' here points to data in the local frame
('target'), which potentially goes out of scope before an asynchronous
'gomp_copy_host2dev' has completed. Thus, don't we have to pass here
'ephemeral <- true' instead of 'ephemeral <- false'? Or, actually
instead of '&target', pass '&hostaddrs[i]', which then again points to
non-ephemeral data? Is the latter safe to do, or are we potentially
further down the line modifying the data that '&hostaddrs[i]' points to?
(I got a bit lost in the use of 'hostaddrs[i]' here.)
> + ++i;
> + }
> continue;
> case GOMP_MAP_FIRSTPRIVATE_INT:
> case GOMP_MAP_ZERO_LEN_ARRAY_SECTION:
> @@ -2517,6 +2534,11 @@ copy_firstprivate_data (char *tgt, size_t mapnum, void **hostaddrs,
> memcpy (tgt + tgt_size, hostaddrs[i], sizes[i]);
> hostaddrs[i] = tgt + tgt_size;
> tgt_size = tgt_size + sizes[i];
> + if (i + 1 < mapnum && (kinds[i+1] & 0xff) == GOMP_MAP_ATTACH)
> + {
> + *(*(uintptr_t**) hostaddrs[i+1] + sizes[i+1]) = (uintptr_t) hostaddrs[i];
> + ++i;
> + }
> }
> }
For reference, the 'gomp_copy_host2dev' code that I highlighted above
still triggers for the following test cases only:
> --- /dev/null
> +++ b/libgomp/testsuite/libgomp.fortran/target-firstprivate-1.f90
> @@ -0,0 +1,33 @@
> +! PR fortran/104949
> +
> +implicit none (type,external)
> +integer, allocatable :: A(:)
> +A = [1,2,3,4,5,6]
> +
> +!$omp parallel firstprivate(A)
> +!$omp master
> + if (any (A /= [1,2,3,4,5])) error stop
> + A(:) = [99,88,77,66,55]
> +!$omp end master
> +!$omp end parallel
> +
> +!$omp target firstprivate(A)
> + if (any (A /= [1,2,3,4,5])) error stop
> + A(:) = [99,88,77,66,55]
> +!$omp end target
> +if (any (A /= [1,2,3,4,5])) error stop
> +
> +!$omp parallel default(firstprivate)
> +!$omp master
> + if (any (A /= [1,2,3,4,5])) error stop
> + A(:) = [99,88,77,66,55]
> +!$omp end master
> +!$omp end parallel
> +if (any (A /= [1,2,3,4,5])) error stop
> +
> +!$omp target defaultmap(firstprivate)
> + if (any (A /= [1,2,3,4,5])) error stop
> + A(:) = [99,88,77,66,55]
> +!$omp end target
> +if (any (A /= [1,2,3,4,5])) error stop
> +end
> --- /dev/null
> +++ b/libgomp/testsuite/libgomp.fortran/target-firstprivate-2.f90
> @@ -0,0 +1,113 @@
> +! PR fortran/104949
> +
> +module m
> +use omp_lib
> +implicit none (type, external)
> +
> +contains
> +subroutine one
> + integer, allocatable :: x(:)
> + integer :: i
> +
> + do i = 1, omp_get_num_devices() + 1
> + !$omp target firstprivate(x)
> + if (allocated(x)) error stop
> + !$omp end target
> + if (allocated(x)) error stop
> + end do
> +
> + do i = 1, omp_get_num_devices() + 1
> + !$omp target firstprivate(x, i)
> + if (allocated(x)) error stop
> + x = [10,20,30,40] + i
> + if (any (x /= [10,20,30,40] + i)) error stop
> + ! This leaks memory!
> + ! deallocate(x)
> + !$omp end target
> + if (allocated(x)) error stop
> + end do
> +
> + x = [1,2,3,4]
> +
> + do i = 1, omp_get_num_devices() + 1
> + !$omp target firstprivate(x, i)
> + if (i <= 0) error stop
> + if (.not.allocated(x)) error stop
> + if (size(x) /= 4) error stop
> + if (lbound(x,1) /= 1) error stop
> + if (any (x /= [1,2,3,4])) error stop
> + ! no reallocation, just malloced + assignment
> + x = [10,20,30,40] + i
> + if (any (x /= [10,20,30,40] + i)) error stop
> + ! This leaks memory!
> + ! deallocate(x)
> + !$omp end target
> + if (.not.allocated(x)) error stop
> + if (size(x) /= 4) error stop
> + if (lbound(x,1) /= 1) error stop
> + if (any (x /= [1,2,3,4])) error stop
> + end do
> + deallocate(x)
> +end
> +
> +subroutine two
> + character(len=:), allocatable :: x(:)
> + character(len=5) :: str
> + integer :: i
> +
> + str = "abcde" ! work around for PR fortran/91544
> + do i = 1, omp_get_num_devices() + 1
> + !$omp target firstprivate(x)
> + if (allocated(x)) error stop
> + !$omp end target
> + if (allocated(x)) error stop
> + end do
> +
> + do i = 1, omp_get_num_devices() + 1
> + !$omp target firstprivate(x, i)
> + if (allocated(x)) error stop
> + ! no reallocation, just malloced + assignment
> + x = [character(len=2+i) :: str,"fhji","klmno"]
> + if (len(x) /= 2+i) error stop
> + if (any (x /= [character(len=2+i) :: str,"fhji","klmno"])) error stop
> + ! This leaks memory!
> + ! deallocate(x)
> + !$omp end target
> + if (allocated(x)) error stop
> + end do
> +
> + x = [character(len=4) :: "ABCDE","FHJI","KLMNO"]
> +
> + do i = 1, omp_get_num_devices() + 1
> + !$omp target firstprivate(x, i)
> + if (i <= 0) error stop
> + if (.not.allocated(x)) error stop
> + if (size(x) /= 3) error stop
> + if (lbound(x,1) /= 1) error stop
> + if (len(x) /= 4) error stop
> + if (any (x /= [character(len=4) :: "ABCDE","FHJI","KLMNO"])) error stop
> + !! Reallocation runs into the issue PR fortran/105538
> + !!
> + !!x = [character(len=2+i) :: str,"fhji","klmno"]
> + !!if (len(x) /= 2+i) error stop
> + !!if (any (x /= [character(len=2+i) :: str,"fhji","klmno"])) error stop
> + !! This leaks memory!
> + !! deallocate(x)
> + ! Just assign:
> + x = [character(len=4) :: "abcde","fhji","klmno"]
> + if (any (x /= [character(len=4) :: "abcde","fhji","klmno"])) error stop
> + !$omp end target
> + if (.not.allocated(x)) error stop
> + if (lbound(x,1) /= 1) error stop
> + if (size(x) /= 3) error stop
> + if (len(x) /= 4) error stop
> + if (any (x /= [character(len=4) :: "ABCDE","FHJI","KLMNO"])) error stop
> + end do
> + deallocate(x)
> +end
> +end module m
> +
> +use m
> +call one
> +call two
> +end
> --- /dev/null
> +++ b/libgomp/testsuite/libgomp.fortran/target-firstprivate-3.f90
> @@ -0,0 +1,24 @@
> +implicit none
> + integer, allocatable :: x(:)
> + x = [1,2,3,4]
> + call foo(x)
> + if (any (x /= [1,2,3,4])) error stop
> + call foo()
> +contains
> +subroutine foo(c)
> + integer, allocatable, optional :: c(:)
> + logical :: is_present
> + is_present = present (c)
> + !$omp target firstprivate(c)
> + if (is_present) then
> + if (.not. allocated(c)) error stop
> + if (any (c /= [1,2,3,4])) error stop
> + c = [99,88,77,66]
> + if (any (c /= [99,88,77,66])) error stop
> + end if
> + !$omp end target
> + if (is_present) then
> + if (any (c /= [1,2,3,4])) error stop
> + end if
> +end
> +end
Grüße
Thomas
-----------------
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
OpenMP: Handle descriptors in target's firstprivate [PR104949]
For allocatable/pointer arrays, a firstprivate to a device
not only needs to privatize the descriptor but also the actual
data. This is implemented as:
firstprivate(x) firstprivate(x.data) attach(x [bias: &x.data-&x)
where the address of x in device memory is saved in hostaddrs[i]
by libgomp and the middle end actually passes hostaddrs[i]' to
attach.
As side effect, has_device_addr(array_desc) had to be changed:
before, it was converted to firstprivate in the front end; now
it is handled in omp-low.cc as has_device_addr requires a shallow
firstprivate (not touching the data pointer) while the normal
firstprivate requires (now) a deep firstprivate.
gcc/fortran/ChangeLog:
PR fortran/104949
* f95-lang.cc (LANG_HOOKS_OMP_ARRAY_SIZE): Redefine.
* trans-openmp.cc (gfc_omp_array_size): New.
(gfc_trans_omp_variable_list): Never turn has_device_addr
to firstprivate.
* trans.h (gfc_omp_array_size): New.
gcc/ChangeLog:
PR fortran/104949
* langhooks-def.h (lhd_omp_array_size): New.
(LANG_HOOKS_OMP_ARRAY_SIZE): Define
(LANG_HOOKS_DECLS): Add it.
* langhooks.cc (lhd_omp_array_size): New.
* langhooks.h (struct lang_hooks_for_decls): Add hook.
* omp-low.cc (scan_sharing_clauses, lower_omp_target):
Handle GOMP_MAP_FIRSTPRIVATE for array descriptors.
libgomp/ChangeLog:
PR fortran/104949
* target.c (gomp_map_vars_internal, copy_firstprivate_data):
Support attach for GOMP_MAP_FIRSTPRIVATE.
* testsuite/libgomp.fortran/target-firstprivate-1.f90: New test.
* testsuite/libgomp.fortran/target-firstprivate-2.f90: New test.
* testsuite/libgomp.fortran/target-firstprivate-3.f90: New test.
gcc/fortran/f95-lang.cc | 2 +
gcc/fortran/trans-openmp.cc | 53 ++++++++--
gcc/fortran/trans.h | 1 +
gcc/langhooks-def.h | 3 +
gcc/langhooks.cc | 8 ++
gcc/langhooks.h | 5 +
gcc/omp-low.cc | 102 ++++++++++++++++++-
libgomp/target.c | 22 ++++
.../libgomp.fortran/target-firstprivate-1.f90 | 33 ++++++
.../libgomp.fortran/target-firstprivate-2.f90 | 113 +++++++++++++++++++++
.../libgomp.fortran/target-firstprivate-3.f90 | 24 +++++
11 files changed, 355 insertions(+), 11 deletions(-)
@@ -114,6 +114,7 @@ static const struct attribute_spec gfc_attribute_table[] =
#undef LANG_HOOKS_TYPE_FOR_SIZE
#undef LANG_HOOKS_INIT_TS
#undef LANG_HOOKS_OMP_ARRAY_DATA
+#undef LANG_HOOKS_OMP_ARRAY_SIZE
#undef LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR
#undef LANG_HOOKS_OMP_CHECK_OPTIONAL_ARGUMENT
#undef LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE
@@ -152,6 +153,7 @@ static const struct attribute_spec gfc_attribute_table[] =
#define LANG_HOOKS_TYPE_FOR_SIZE gfc_type_for_size
#define LANG_HOOKS_INIT_TS gfc_init_ts
#define LANG_HOOKS_OMP_ARRAY_DATA gfc_omp_array_data
+#define LANG_HOOKS_OMP_ARRAY_SIZE gfc_omp_array_size
#define LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR gfc_omp_is_allocatable_or_ptr
#define LANG_HOOKS_OMP_CHECK_OPTIONAL_ARGUMENT gfc_omp_check_optional_argument
#define LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE gfc_omp_privatize_by_reference
@@ -169,6 +169,48 @@ gfc_omp_array_data (tree decl, bool type_only)
return decl;
}
+/* Return the byte-size of the passed array descriptor. */
+
+tree
+gfc_omp_array_size (tree decl, gimple_seq *pre_p)
+{
+ stmtblock_t block;
+ if (POINTER_TYPE_P (TREE_TYPE (decl)))
+ decl = build_fold_indirect_ref (decl);
+ tree type = TREE_TYPE (decl);
+ gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
+ bool allocatable = (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
+ || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT);
+ gfc_init_block (&block);
+ tree size = gfc_full_array_size (&block, decl,
+ GFC_TYPE_ARRAY_RANK (TREE_TYPE (decl)));
+ size = fold_convert (size_type_node, size);
+ tree elemsz = gfc_get_element_type (TREE_TYPE (decl));
+ if (TREE_CODE (elemsz) == ARRAY_TYPE && TYPE_STRING_FLAG (elemsz))
+ elemsz = gfc_conv_descriptor_elem_len (decl);
+ else
+ elemsz = TYPE_SIZE_UNIT (elemsz);
+ size = fold_build2 (MULT_EXPR, size_type_node, size, elemsz);
+ if (!allocatable)
+ gimplify_and_add (gfc_finish_block (&block), pre_p);
+ else
+ {
+ tree var = create_tmp_var (size_type_node);
+ gfc_add_expr_to_block (&block, build2 (MODIFY_EXPR, sizetype, var, size));
+ tree tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
+ gfc_conv_descriptor_data_get (decl),
+ null_pointer_node);
+ tmp = build3_loc (input_location, COND_EXPR, void_type_node, tmp,
+ gfc_finish_block (&block),
+ build2 (MODIFY_EXPR, sizetype, var, size_zero_node));
+ gimplify_and_add (tmp, pre_p);
+ size = var;
+ }
+ return size;
+}
+
+
/* True if OpenMP should privatize what this DECL points to rather
than the DECL itself. */
@@ -1922,16 +1964,7 @@ gfc_trans_omp_variable_list (enum omp_clause_code code,
if (t != error_mark_node)
{
tree node;
- /* For HAS_DEVICE_ADDR of an array descriptor, firstprivatize the
- descriptor such that the bounds are available; its data component
- is unmodified; it is handled as device address inside target. */
- if (code == OMP_CLAUSE_HAS_DEVICE_ADDR
- && (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (t))
- || (POINTER_TYPE_P (TREE_TYPE (t))
- && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (t))))))
- node = build_omp_clause (input_location, OMP_CLAUSE_FIRSTPRIVATE);
- else
- node = build_omp_clause (input_location, code);
+ node = build_omp_clause (input_location, code);
OMP_CLAUSE_DECL (node) = t;
list = gfc_trans_add_clause (node, list);
@@ -808,6 +808,7 @@ bool gfc_get_array_descr_info (const_tree, struct array_descr_info *);
bool gfc_omp_is_allocatable_or_ptr (const_tree);
tree gfc_omp_check_optional_argument (tree, bool);
tree gfc_omp_array_data (tree, bool);
+tree gfc_omp_array_size (tree, gimple_seq *);
bool gfc_omp_privatize_by_reference (const_tree);
enum omp_clause_default_kind gfc_omp_predetermined_sharing (tree);
enum omp_clause_defaultmap_kind gfc_omp_predetermined_mapping (tree);
@@ -84,6 +84,7 @@ extern enum omp_clause_default_kind lhd_omp_predetermined_sharing (tree);
extern enum omp_clause_defaultmap_kind lhd_omp_predetermined_mapping (tree);
extern tree lhd_omp_assignment (tree, tree, tree);
extern void lhd_omp_finish_clause (tree, gimple_seq *, bool);
+extern tree lhd_omp_array_size (tree, gimple_seq *);
struct gimplify_omp_ctx;
extern void lhd_omp_firstprivatize_type_sizes (struct gimplify_omp_ctx *,
tree);
@@ -257,6 +258,7 @@ extern tree lhd_unit_size_without_reusable_padding (tree);
#define LANG_HOOKS_POST_COMPILATION_PARSING_CLEANUPS NULL
#define LANG_HOOKS_DECL_OK_FOR_SIBCALL lhd_decl_ok_for_sibcall
#define LANG_HOOKS_OMP_ARRAY_DATA hook_tree_tree_bool_null
+#define LANG_HOOKS_OMP_ARRAY_SIZE lhd_omp_array_size
#define LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR hook_bool_const_tree_false
#define LANG_HOOKS_OMP_CHECK_OPTIONAL_ARGUMENT hook_tree_tree_bool_null
#define LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE hook_bool_const_tree_false
@@ -290,6 +292,7 @@ extern tree lhd_unit_size_without_reusable_padding (tree);
LANG_HOOKS_POST_COMPILATION_PARSING_CLEANUPS, \
LANG_HOOKS_DECL_OK_FOR_SIBCALL, \
LANG_HOOKS_OMP_ARRAY_DATA, \
+ LANG_HOOKS_OMP_ARRAY_SIZE, \
LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR, \
LANG_HOOKS_OMP_CHECK_OPTIONAL_ARGUMENT, \
LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE, \
@@ -634,6 +634,14 @@ lhd_omp_finish_clause (tree, gimple_seq *, bool)
{
}
+/* Return array size; cf. omp_array_data. */
+
+tree
+lhd_omp_array_size (tree, gimple_seq *)
+{
+ return NULL_TREE;
+}
+
/* Return true if DECL is a scalar variable (for the purpose of
implicit firstprivatization & mapping). Only if alloc_ptr_ok
are allocatables and pointers accepted. */
@@ -246,6 +246,11 @@ struct lang_hooks_for_decls
is true, only the TREE_TYPE is returned without generating a new tree. */
tree (*omp_array_data) (tree, bool);
+ /* Return a tree for the actual data of an array descriptor - or NULL_TREE
+ if original tree is not an array descriptor. If the second argument
+ is true, only the TREE_TYPE is returned without generating a new tree. */
+ tree (*omp_array_size) (tree, gimple_seq *pre_p);
+
/* True if OpenMP should regard this DECL as being a scalar which has Fortran's
allocatable or pointer attribute. */
bool (*omp_is_allocatable_or_ptr) (const_tree);
@@ -1372,7 +1372,9 @@ scan_sharing_clauses (tree clauses, omp_context *ctx)
|| OMP_CLAUSE_CODE (c) == OMP_CLAUSE_HAS_DEVICE_ADDR)
&& is_gimple_omp_offloaded (ctx->stmt))
{
- if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_FIRSTPRIVATE)
+ if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_FIRSTPRIVATE
+ || (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_HAS_DEVICE_ADDR
+ && lang_hooks.decls.omp_array_data (decl, true)))
{
by_ref = !omp_privatize_by_reference (decl);
install_var_field (decl, by_ref, 3, ctx);
@@ -1424,6 +1426,15 @@ scan_sharing_clauses (tree clauses, omp_context *ctx)
install_var_field (decl, by_ref, 3, ctx);
}
install_var_local (decl, ctx);
+ /* For descr arrays on target: firstprivatize data + attach ptr. */
+ if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_FIRSTPRIVATE
+ && is_gimple_omp_offloaded (ctx->stmt)
+ && !is_gimple_omp_oacc (ctx->stmt)
+ && lang_hooks.decls.omp_array_data (decl, true))
+ {
+ install_var_field (decl, false, 16 | 3, ctx);
+ install_var_field (decl, true, 8 | 3, ctx);
+ }
break;
case OMP_CLAUSE_USE_DEVICE_PTR:
@@ -12825,6 +12836,7 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
break;
case OMP_CLAUSE_FIRSTPRIVATE:
+ omp_firstprivate_recv:
gcc_checking_assert (offloaded);
if (is_gimple_omp_oacc (ctx->stmt))
{
@@ -12856,6 +12868,10 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
SET_DECL_VALUE_EXPR (new_var, x);
DECL_HAS_VALUE_EXPR_P (new_var) = 1;
}
+ /* Fortran array descriptors: firstprivate of data + attach. */
+ if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_HAS_DEVICE_ADDR
+ && lang_hooks.decls.omp_array_data (var, true))
+ map_cnt += 2;
break;
case OMP_CLAUSE_PRIVATE:
@@ -12895,6 +12911,8 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
while (TREE_CODE (var) == INDIRECT_REF
|| TREE_CODE (var) == ARRAY_REF)
var = TREE_OPERAND (var, 0);
+ if (lang_hooks.decls.omp_array_data (var, true))
+ goto omp_firstprivate_recv;
}
map_cnt++;
if (is_variable_sized (var))
@@ -13308,6 +13326,7 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
break;
case OMP_CLAUSE_FIRSTPRIVATE:
+ omp_has_device_addr_descr:
if (is_gimple_omp_oacc (ctx->stmt))
goto oacc_firstprivate_map;
ovar = OMP_CLAUSE_DECL (c);
@@ -13373,6 +13392,82 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
<= tree_to_uhwi (TYPE_MAX_VALUE (tkind_type)));
CONSTRUCTOR_APPEND_ELT (vkind, purpose,
build_int_cstu (tkind_type, tkind));
+ /* Fortran array descriptors: firstprivate of data + attach. */
+ if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_HAS_DEVICE_ADDR
+ && lang_hooks.decls.omp_array_data (ovar, true))
+ {
+ tree not_null_lb, null_lb, after_lb;
+ tree var1, var2, size1, size2;
+ tree present = omp_check_optional_argument (ovar, true);
+ if (present)
+ {
+ location_t clause_loc = OMP_CLAUSE_LOCATION (c);
+ not_null_lb = create_artificial_label (clause_loc);
+ null_lb = create_artificial_label (clause_loc);
+ after_lb = create_artificial_label (clause_loc);
+ gimple_seq seq = NULL;
+ present = force_gimple_operand (present, &seq, true,
+ NULL_TREE);
+ gimple_seq_add_seq (&ilist, seq);
+ gimple_seq_add_stmt (&ilist,
+ gimple_build_cond_from_tree (present,
+ not_null_lb, null_lb));
+ gimple_seq_add_stmt (&ilist,
+ gimple_build_label (not_null_lb));
+ }
+ var1 = lang_hooks.decls.omp_array_data (var, false);
+ size1 = lang_hooks.decls.omp_array_size (var, &ilist);
+ var2 = build_fold_addr_expr (x);
+ if (!POINTER_TYPE_P (TREE_TYPE (var)))
+ var = build_fold_addr_expr (var);
+ size2 = fold_build2 (POINTER_DIFF_EXPR, ssizetype,
+ build_fold_addr_expr (var1), var);
+ size2 = fold_convert (sizetype, size2);
+ if (present)
+ {
+ tree tmp = create_tmp_var (TREE_TYPE (var1));
+ gimplify_assign (tmp, var1, &ilist);
+ var1 = tmp;
+ tmp = create_tmp_var (TREE_TYPE (var2));
+ gimplify_assign (tmp, var2, &ilist);
+ var2 = tmp;
+ tmp = create_tmp_var (TREE_TYPE (size1));
+ gimplify_assign (tmp, size1, &ilist);
+ size1 = tmp;
+ tmp = create_tmp_var (TREE_TYPE (size2));
+ gimplify_assign (tmp, size2, &ilist);
+ size2 = tmp;
+ gimple_seq_add_stmt (&ilist, gimple_build_goto (after_lb));
+ gimple_seq_add_stmt (&ilist, gimple_build_label (null_lb));
+ gimplify_assign (var1, null_pointer_node, &ilist);
+ gimplify_assign (var2, null_pointer_node, &ilist);
+ gimplify_assign (size1, size_zero_node, &ilist);
+ gimplify_assign (size2, size_zero_node, &ilist);
+ gimple_seq_add_stmt (&ilist, gimple_build_label (after_lb));
+ }
+ x = build_sender_ref ((splay_tree_key) &DECL_NAME (ovar), ctx);
+ gimplify_assign (x, var1, &ilist);
+ tkind = GOMP_MAP_FIRSTPRIVATE;
+ talign = DECL_ALIGN_UNIT (ovar);
+ talign = ceil_log2 (talign);
+ tkind |= talign << talign_shift;
+ gcc_checking_assert (tkind
+ <= tree_to_uhwi (
+ TYPE_MAX_VALUE (tkind_type)));
+ purpose = size_int (map_idx++);
+ CONSTRUCTOR_APPEND_ELT (vsize, purpose, size1);
+ if (TREE_CODE (size1) != INTEGER_CST)
+ TREE_STATIC (TREE_VEC_ELT (t, 1)) = 0;
+ CONSTRUCTOR_APPEND_ELT (vkind, purpose,
+ build_int_cstu (tkind_type, tkind));
+ x = build_sender_ref ((splay_tree_key) &DECL_UID (ovar), ctx);
+ gimplify_assign (x, var2, &ilist);
+ tkind = GOMP_MAP_ATTACH;
+ purpose = size_int (map_idx++);
+ CONSTRUCTOR_APPEND_ELT (vsize, purpose, size2);
+ CONSTRUCTOR_APPEND_ELT (vkind, purpose,
+ build_int_cstu (tkind_type, tkind));
+ }
break;
case OMP_CLAUSE_USE_DEVICE_PTR:
@@ -13382,6 +13477,8 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
ovar = OMP_CLAUSE_DECL (c);
if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_HAS_DEVICE_ADDR)
{
+ if (lang_hooks.decls.omp_array_data (ovar, true))
+ goto omp_has_device_addr_descr;
while (TREE_CODE (ovar) == INDIRECT_REF
|| TREE_CODE (ovar) == ARRAY_REF)
ovar = TREE_OPERAND (ovar, 0);
@@ -13548,6 +13645,7 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
default:
break;
case OMP_CLAUSE_FIRSTPRIVATE:
+ omp_firstprivatize_data_region:
if (is_gimple_omp_oacc (ctx->stmt))
break;
var = OMP_CLAUSE_DECL (c);
@@ -13642,6 +13740,8 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
do_optional_check = false;
var = OMP_CLAUSE_DECL (c);
is_array_data = lang_hooks.decls.omp_array_data (var, true) != NULL;
+ if (OMP_CLAUSE_CODE (c) == OMP_CLAUSE_HAS_DEVICE_ADDR && is_array_data)
+ goto omp_firstprivatize_data_region;
if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_IS_DEVICE_PTR
&& OMP_CLAUSE_CODE (c) != OMP_CLAUSE_HAS_DEVICE_ADDR)
@@ -1350,7 +1350,24 @@ gomp_map_vars_internal (struct gomp_device_descr *devicep,
gomp_copy_host2dev (devicep, aq,
(void *) (tgt->tgt_start + tgt_size),
(void *) hostaddrs[i], len, false, cbufp);
+ /* Save device address in hostaddr to permit latter availablity
+ when doing a deep-firstprivate with pointer attach. */
+ hostaddrs[i] = (void *) (tgt->tgt_start + tgt_size);
tgt_size += len;
+
+ /* If followed by GOMP_MAP_ATTACH, pointer assign this
+ firstprivate to hostaddrs[i+1], which is assumed to contain a
+ device address. */
+ if (i + 1 < mapnum
+ && (GOMP_MAP_ATTACH
+ == (typemask & get_kind (short_mapkind, kinds, i+1))))
+ {
+ uintptr_t target = (uintptr_t) hostaddrs[i];
+ void *devptr = *(void**) hostaddrs[i+1] + sizes[i+1];
+ gomp_copy_host2dev (devicep, aq, devptr, &target,
+ sizeof (void *), false, cbufp);
+ ++i;
+ }
continue;
case GOMP_MAP_FIRSTPRIVATE_INT:
case GOMP_MAP_ZERO_LEN_ARRAY_SECTION:
@@ -2517,6 +2534,11 @@ copy_firstprivate_data (char *tgt, size_t mapnum, void **hostaddrs,
memcpy (tgt + tgt_size, hostaddrs[i], sizes[i]);
hostaddrs[i] = tgt + tgt_size;
tgt_size = tgt_size + sizes[i];
+ if (i + 1 < mapnum && (kinds[i+1] & 0xff) == GOMP_MAP_ATTACH)
+ {
+ *(*(uintptr_t**) hostaddrs[i+1] + sizes[i+1]) = (uintptr_t) hostaddrs[i];
+ ++i;
+ }
}
}
new file mode 100644
@@ -0,0 +1,33 @@
+! PR fortran/104949
+
+implicit none (type,external)
+integer, allocatable :: A(:)
+A = [1,2,3,4,5,6]
+
+!$omp parallel firstprivate(A)
+!$omp master
+ if (any (A /= [1,2,3,4,5])) error stop
+ A(:) = [99,88,77,66,55]
+!$omp end master
+!$omp end parallel
+
+!$omp target firstprivate(A)
+ if (any (A /= [1,2,3,4,5])) error stop
+ A(:) = [99,88,77,66,55]
+!$omp end target
+if (any (A /= [1,2,3,4,5])) error stop
+
+!$omp parallel default(firstprivate)
+!$omp master
+ if (any (A /= [1,2,3,4,5])) error stop
+ A(:) = [99,88,77,66,55]
+!$omp end master
+!$omp end parallel
+if (any (A /= [1,2,3,4,5])) error stop
+
+!$omp target defaultmap(firstprivate)
+ if (any (A /= [1,2,3,4,5])) error stop
+ A(:) = [99,88,77,66,55]
+!$omp end target
+if (any (A /= [1,2,3,4,5])) error stop
+end
new file mode 100644
@@ -0,0 +1,113 @@
+! PR fortran/104949
+
+module m
+use omp_lib
+implicit none (type, external)
+
+contains
+subroutine one
+ integer, allocatable :: x(:)
+ integer :: i
+
+ do i = 1, omp_get_num_devices() + 1
+ !$omp target firstprivate(x)
+ if (allocated(x)) error stop
+ !$omp end target
+ if (allocated(x)) error stop
+ end do
+
+ do i = 1, omp_get_num_devices() + 1
+ !$omp target firstprivate(x, i)
+ if (allocated(x)) error stop
+ x = [10,20,30,40] + i
+ if (any (x /= [10,20,30,40] + i)) error stop
+ ! This leaks memory!
+ ! deallocate(x)
+ !$omp end target
+ if (allocated(x)) error stop
+ end do
+
+ x = [1,2,3,4]
+
+ do i = 1, omp_get_num_devices() + 1
+ !$omp target firstprivate(x, i)
+ if (i <= 0) error stop
+ if (.not.allocated(x)) error stop
+ if (size(x) /= 4) error stop
+ if (lbound(x,1) /= 1) error stop
+ if (any (x /= [1,2,3,4])) error stop
+ ! no reallocation, just malloced + assignment
+ x = [10,20,30,40] + i
+ if (any (x /= [10,20,30,40] + i)) error stop
+ ! This leaks memory!
+ ! deallocate(x)
+ !$omp end target
+ if (.not.allocated(x)) error stop
+ if (size(x) /= 4) error stop
+ if (lbound(x,1) /= 1) error stop
+ if (any (x /= [1,2,3,4])) error stop
+ end do
+ deallocate(x)
+end
+
+subroutine two
+ character(len=:), allocatable :: x(:)
+ character(len=5) :: str
+ integer :: i
+
+ str = "abcde" ! work around for PR fortran/91544
+ do i = 1, omp_get_num_devices() + 1
+ !$omp target firstprivate(x)
+ if (allocated(x)) error stop
+ !$omp end target
+ if (allocated(x)) error stop
+ end do
+
+ do i = 1, omp_get_num_devices() + 1
+ !$omp target firstprivate(x, i)
+ if (allocated(x)) error stop
+ ! no reallocation, just malloced + assignment
+ x = [character(len=2+i) :: str,"fhji","klmno"]
+ if (len(x) /= 2+i) error stop
+ if (any (x /= [character(len=2+i) :: str,"fhji","klmno"])) error stop
+ ! This leaks memory!
+ ! deallocate(x)
+ !$omp end target
+ if (allocated(x)) error stop
+ end do
+
+ x = [character(len=4) :: "ABCDE","FHJI","KLMNO"]
+
+ do i = 1, omp_get_num_devices() + 1
+ !$omp target firstprivate(x, i)
+ if (i <= 0) error stop
+ if (.not.allocated(x)) error stop
+ if (size(x) /= 3) error stop
+ if (lbound(x,1) /= 1) error stop
+ if (len(x) /= 4) error stop
+ if (any (x /= [character(len=4) :: "ABCDE","FHJI","KLMNO"])) error stop
+ !! Reallocation runs into the issue PR fortran/105538
+ !!
+ !!x = [character(len=2+i) :: str,"fhji","klmno"]
+ !!if (len(x) /= 2+i) error stop
+ !!if (any (x /= [character(len=2+i) :: str,"fhji","klmno"])) error stop
+ !! This leaks memory!
+ !! deallocate(x)
+ ! Just assign:
+ x = [character(len=4) :: "abcde","fhji","klmno"]
+ if (any (x /= [character(len=4) :: "abcde","fhji","klmno"])) error stop
+ !$omp end target
+ if (.not.allocated(x)) error stop
+ if (lbound(x,1) /= 1) error stop
+ if (size(x) /= 3) error stop
+ if (len(x) /= 4) error stop
+ if (any (x /= [character(len=4) :: "ABCDE","FHJI","KLMNO"])) error stop
+ end do
+ deallocate(x)
+end
+end module m
+
+use m
+call one
+call two
+end
new file mode 100644
@@ -0,0 +1,24 @@
+implicit none
+ integer, allocatable :: x(:)
+ x = [1,2,3,4]
+ call foo(x)
+ if (any (x /= [1,2,3,4])) error stop
+ call foo()
+contains
+subroutine foo(c)
+ integer, allocatable, optional :: c(:)
+ logical :: is_present
+ is_present = present (c)
+ !$omp target firstprivate(c)
+ if (is_present) then
+ if (.not. allocated(c)) error stop
+ if (any (c /= [1,2,3,4])) error stop
+ c = [99,88,77,66]
+ if (any (c /= [99,88,77,66])) error stop
+ end if
+ !$omp end target
+ if (is_present) then
+ if (any (c /= [1,2,3,4])) error stop
+ end if
+end
+end