2019-09-27 Tobias Burnus <tobias@codesourcery.com>
gcc/fortran/
* trans.h (gfc_omp_array_data): Declare.
* trans-openmp.c (gfc_omp_array_data): New.
* f95-lang.c (LANG_HOOKS_OMP_ARRAY_DATA): Use it.
* trans-array.c (gfc_conv_descriptor_data_get): Handle
reference types.
gcc/
* hooks.h (hook_tree_tree_null): Declare.
* hooks.c (hook_tree_tree_null): New.
* langhooks-def.h (LANG_HOOKS_OMP_ARRAY_DATA): New.
(LANG_HOOKS_FOR_TYPES_INITIALIZER): Add it.
* langhooks.h (lang_hooks_for_types): Add omp_array_data.
* omp-low.c (omp_context): Add array_data_map.
(install_var_field): Handle unnamed field declarations.
(delete_omp_context): Dealloc array_data_map.
(scan_sharing_clauses, lower_omp_target): Handle
array descriptors in use_device_ptr.
gcc/testsuite/
* gfortran.dg/gomp/use_device_ptr1.f90: New.
* gfortran.dg/gomp/use_device_ptr2.f90: New.
* gfortran.dg/gomp/use_device_ptr3.f90: New.
libgomp/
* testsuite/libgomp.fortran/use_device_ptr1.f90: New.
gcc/fortran/f95-lang.c | 2 +
gcc/fortran/trans-array.c | 3 +
gcc/fortran/trans-openmp.c | 19 +
gcc/fortran/trans.h | 1 +
gcc/hooks.c | 6 +
gcc/hooks.h | 1 +
gcc/langhooks-def.h | 2 +
gcc/langhooks.h | 4 +
gcc/omp-low.c | 113 +++-
gcc/testsuite/gfortran.dg/gomp/use_device_ptr1.f90 | 102 ++++
gcc/testsuite/gfortran.dg/gomp/use_device_ptr2.f90 | 107 ++++
gcc/testsuite/gfortran.dg/gomp/use_device_ptr3.f90 | 108 ++++
.../testsuite/libgomp.fortran/use_device_ptr1.f90 | 590 +++++++++++++++++++++
13 files changed, 1047 insertions(+), 11 deletions(-)
@@ -112,6 +112,7 @@ static const struct attribute_spec gfc_attribute_table[] =
#undef LANG_HOOKS_MARK_ADDRESSABLE
#undef LANG_HOOKS_TYPE_FOR_MODE
#undef LANG_HOOKS_TYPE_FOR_SIZE
+#undef LANG_HOOKS_OMP_ARRAY_DATA
#undef LANG_HOOKS_INIT_TS
#undef LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE
#undef LANG_HOOKS_OMP_PREDETERMINED_SHARING
@@ -145,6 +146,7 @@ static const struct attribute_spec gfc_attribute_table[] =
#define LANG_HOOKS_TYPE_FOR_MODE gfc_type_for_mode
#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_PRIVATIZE_BY_REFERENCE gfc_omp_privatize_by_reference
#define LANG_HOOKS_OMP_PREDETERMINED_SHARING gfc_omp_predetermined_sharing
#define LANG_HOOKS_OMP_REPORT_DECL gfc_omp_report_decl
@@ -142,6 +142,9 @@ gfc_conv_descriptor_data_get (tree desc)
tree field, type, t;
type = TREE_TYPE (desc);
+ if (TREE_CODE (type) == REFERENCE_TYPE)
+ type = TREE_TYPE (type);
+
gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
field = TYPE_FIELDS (type);
@@ -47,6 +47,25 @@ along with GCC; see the file COPYING3. If not see
int ompws_flags;
+tree
+gfc_omp_array_data (tree decl)
+{
+ tree type = TREE_TYPE (decl);
+
+ if (TREE_CODE (type) == REFERENCE_TYPE || POINTER_TYPE_P (type))
+ type = TREE_TYPE (type);
+
+ if (!GFC_DESCRIPTOR_TYPE_P (type))
+ return NULL_TREE;
+
+ if (POINTER_TYPE_P (TREE_TYPE (decl)))
+ decl = build_fold_indirect_ref (decl);
+
+ decl = gfc_conv_descriptor_data_get (decl);
+ STRIP_NOPS (decl);
+ return decl;
+}
+
/* True if OpenMP should privatize what this DECL points to rather
than the DECL itself. */
@@ -785,6 +785,7 @@ struct array_descr_info;
bool gfc_get_array_descr_info (const_tree, struct array_descr_info *);
/* In trans-openmp.c */
+tree gfc_omp_array_data (tree);
bool gfc_omp_privatize_by_reference (const_tree);
enum omp_clause_default_kind gfc_omp_predetermined_sharing (tree);
tree gfc_omp_report_decl (tree);
@@ -430,6 +430,12 @@ hook_tree_tree_int_treep_bool_null (tree, int, tree *, bool)
return NULL;
}
+tree
+hook_tree_tree_null (tree)
+{
+ return NULL;
+}
+
tree
hook_tree_tree_tree_null (tree, tree)
{
@@ -106,6 +106,7 @@ extern HOST_WIDE_INT hook_hwi_void_0 (void);
extern tree hook_tree_const_tree_null (const_tree);
extern tree hook_tree_void_null (void);
+extern tree hook_tree_tree_null (tree);
extern tree hook_tree_tree_tree_null (tree, tree);
extern tree hook_tree_tree_tree_tree_null (tree, tree, tree);
extern tree hook_tree_tree_int_treep_bool_null (tree, int, tree *, bool);
@@ -188,6 +188,7 @@ extern tree lhd_unit_size_without_reusable_padding (tree);
#define LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES \
lhd_omp_firstprivatize_type_sizes
#define LANG_HOOKS_OMP_MAPPABLE_TYPE lhd_omp_mappable_type
+#define LANG_HOOKS_OMP_ARRAY_DATA hook_tree_tree_null
#define LANG_HOOKS_TYPE_HASH_EQ NULL
#define LANG_HOOKS_COPY_LANG_QUALIFIERS NULL
#define LANG_HOOKS_GET_ARRAY_DESCR_INFO NULL
@@ -214,6 +215,7 @@ extern tree lhd_unit_size_without_reusable_padding (tree);
LANG_HOOKS_TYPE_MAX_SIZE, \
LANG_HOOKS_OMP_FIRSTPRIVATIZE_TYPE_SIZES, \
LANG_HOOKS_OMP_MAPPABLE_TYPE, \
+ LANG_HOOKS_OMP_ARRAY_DATA, \
LANG_HOOKS_TYPE_HASH_EQ, \
LANG_HOOKS_COPY_LANG_QUALIFIERS, \
LANG_HOOKS_GET_ARRAY_DESCR_INFO, \
@@ -117,6 +117,10 @@ struct lang_hooks_for_types
/* Return true if TYPE is a mappable type. */
bool (*omp_mappable_type) (tree type);
+ /* Return a tree for of the actual data of an array descriptor - or
+ NULL_TREE if original tree is not an array descriptor. */
+ tree (*omp_array_data) (tree);
+
/* Return TRUE if TYPE1 and TYPE2 are identical for type hashing purposes.
Called only after doing all language independent checks.
At present, this function is only called when both TYPE1 and TYPE2 are
@@ -90,6 +90,7 @@ struct omp_context
/* Map variables to fields in a structure that allows communication
between sending and receiving threads. */
splay_tree field_map;
+ splay_tree array_data_map;
tree record_type;
tree sender_decl;
tree receiver_decl;
@@ -715,7 +716,9 @@ install_var_field (tree var, bool by_ref, int mask, omp_context *ctx)
tree field, type, sfield = NULL_TREE;
splay_tree_key key = (splay_tree_key) var;
- if ((mask & 8) != 0)
+ if ((mask & 16) != 0)
+ key = (splay_tree_key) var;
+ else if ((mask & 8) != 0)
{
key = (splay_tree_key) &DECL_UID (var);
gcc_checking_assert (key != (splay_tree_key) var);
@@ -745,14 +748,17 @@ install_var_field (tree var, bool by_ref, int mask, omp_context *ctx)
else if ((mask & 3) == 1 && omp_is_reference (var))
type = TREE_TYPE (type);
- field = build_decl (DECL_SOURCE_LOCATION (var),
- FIELD_DECL, DECL_NAME (var), type);
+ if ((mask & 16) != 0)
+ field = build_decl (UNKNOWN_LOCATION, FIELD_DECL, NULL_TREE, type);
+ else
+ field = build_decl (DECL_SOURCE_LOCATION (var),
+ FIELD_DECL, DECL_NAME (var), type);
/* Remember what variable this field was created for. This does have a
side effect of making dwarf2out ignore this member, so for helpful
debugging we clear it later in delete_omp_context. */
DECL_ABSTRACT_ORIGIN (field) = var;
- if (type == TREE_TYPE (var))
+ if ((mask & 16) == 0 && type == TREE_TYPE (var))
{
SET_DECL_ALIGN (field, DECL_ALIGN (var));
DECL_USER_ALIGN (field) = DECL_USER_ALIGN (var);
@@ -976,6 +982,8 @@ delete_omp_context (splay_tree_value value)
splay_tree_delete (ctx->field_map);
if (ctx->sfield_map)
splay_tree_delete (ctx->sfield_map);
+ if (ctx->array_data_map)
+ splay_tree_delete (ctx->array_data_map);
/* We hijacked DECL_ABSTRACT_ORIGIN earlier. We need to clear it before
it produces corrupt debug information. */
@@ -1070,7 +1078,7 @@ fixup_child_record_type (omp_context *ctx)
static void
scan_sharing_clauses (tree clauses, omp_context *ctx)
{
- tree c, decl;
+ tree c, decl, x;
bool scan_array_reductions = false;
for (c = clauses; c; c = OMP_CLAUSE_CHAIN (c))
@@ -1240,7 +1248,30 @@ scan_sharing_clauses (tree clauses, omp_context *ctx)
case OMP_CLAUSE_USE_DEVICE_PTR:
case OMP_CLAUSE_USE_DEVICE_ADDR:
decl = OMP_CLAUSE_DECL (c);
- if ((OMP_CLAUSE_CODE (c) == OMP_CLAUSE_USE_DEVICE_ADDR
+ x = NULL;
+ // Handle array descriptors
+ if (TREE_CODE (TREE_TYPE (decl)) == RECORD_TYPE ||
+ (omp_is_reference (decl)
+ && TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) == RECORD_TYPE))
+ x = lang_hooks.types.omp_array_data (decl);
+
+ if (x)
+ {
+ gcc_assert (!ctx->array_data_map
+ || !splay_tree_lookup (ctx->array_data_map,
+ (splay_tree_key) decl));
+ if (!ctx->array_data_map)
+ ctx->array_data_map
+ = splay_tree_new (splay_tree_compare_pointers, 0, 0);
+
+ splay_tree_insert (ctx->array_data_map, (splay_tree_key) decl,
+ (splay_tree_value) x);
+
+ install_var_field (x, false, 19, ctx);
+ DECL_SOURCE_LOCATION (lookup_field (x, ctx))
+ = OMP_CLAUSE_LOCATION (c);
+ }
+ else if ((OMP_CLAUSE_CODE (c) == OMP_CLAUSE_USE_DEVICE_ADDR
&& !omp_is_reference (decl))
|| TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE)
install_var_field (decl, true, 11, ctx);
@@ -11852,7 +11883,18 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
case OMP_CLAUSE_IS_DEVICE_PTR:
ovar = OMP_CLAUSE_DECL (c);
var = lookup_decl_in_outer_ctx (ovar, ctx);
- if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_IS_DEVICE_PTR)
+
+ // For arrays with descriptor, use the pointer to the actual data
+ splay_tree_node n = ctx->array_data_map
+ ? splay_tree_lookup (ctx->array_data_map,
+ (splay_tree_key) ovar)
+ : NULL;
+ if (n)
+ {
+ tkind = GOMP_MAP_USE_DEVICE_PTR;
+ x = build_sender_ref ((tree) n->value, ctx);
+ }
+ else if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_IS_DEVICE_PTR)
{
tkind = GOMP_MAP_USE_DEVICE_PTR;
x = build_sender_ref ((splay_tree_key) &DECL_UID (ovar), ctx);
@@ -11863,7 +11905,9 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
x = build_sender_ref (ovar, ctx);
}
type = TREE_TYPE (ovar);
- if ((OMP_CLAUSE_CODE (c) == OMP_CLAUSE_USE_DEVICE_ADDR
+ if (n)
+ var = (tree) n->value;
+ else if ((OMP_CLAUSE_CODE (c) == OMP_CLAUSE_USE_DEVICE_ADDR
&& !omp_is_reference (ovar))
|| TREE_CODE (type) == ARRAY_TYPE)
var = build_fold_addr_expr (var);
@@ -12028,11 +12072,58 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
case OMP_CLAUSE_USE_DEVICE_ADDR:
case OMP_CLAUSE_IS_DEVICE_PTR:
var = OMP_CLAUSE_DECL (c);
+ tree array_data = NULL;
+ if (ctx->array_data_map)
+ {
+ splay_tree_node n = splay_tree_lookup (ctx->array_data_map,
+ (splay_tree_key) var);
+ if (n)
+ array_data = (tree) n->value;
+ }
+
if (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_IS_DEVICE_PTR)
- x = build_sender_ref ((splay_tree_key) &DECL_UID (var), ctx);
+ x = build_sender_ref (array_data
+ ? (splay_tree_key) array_data
+ : (splay_tree_key) &DECL_UID (var), ctx);
else
- x = build_receiver_ref (var, false, ctx);
- if (is_variable_sized (var))
+ x = build_receiver_ref (array_data ? array_data : var, false, ctx);
+
+ if (array_data)
+ {
+ tree new_var = lookup_decl (var, ctx);
+ new_var = DECL_VALUE_EXPR (new_var);
+ if (omp_is_reference (var)
+ && OMP_CLAUSE_CODE (c) != OMP_CLAUSE_USE_DEVICE_ADDR)
+ {
+ tree type = TREE_TYPE (TREE_TYPE (var));
+ tree v = create_tmp_var_raw (type, get_name (var));
+ gimple_add_tmp_var (v);
+ TREE_ADDRESSABLE (v) = 1;
+ tree x2 = build_fold_indirect_ref (var);
+ gimplify_expr (&x2, &new_body, NULL, is_gimple_val, fb_rvalue);
+ gimple_seq_add_stmt (&new_body, gimple_build_assign (v, x2));
+
+ tree v2 = lang_hooks.types.omp_array_data (v);
+ gcc_assert (v2);
+ gimplify_expr (&x, &new_body, NULL, is_gimple_val, fb_rvalue);
+ gimple_seq_add_stmt (&new_body,
+ gimple_build_assign (v2, x));
+ x = build_fold_addr_expr (v);
+ gimple_seq_add_stmt (&new_body,
+ gimple_build_assign (new_var, x));
+ }
+ else
+ {
+ gimple_seq_add_stmt (&new_body,
+ gimple_build_assign (new_var, var));
+ new_var = lang_hooks.types.omp_array_data (new_var);
+ gcc_assert (new_var);
+ gimplify_expr (&x, &new_body, NULL, is_gimple_val, fb_rvalue);
+ gimple_seq_add_stmt (&new_body,
+ gimple_build_assign (new_var, x));
+ }
+ }
+ else if (is_variable_sized (var))
{
tree pvar = DECL_VALUE_EXPR (var);
gcc_assert (TREE_CODE (pvar) == INDIRECT_REF);
new file mode 100644
@@ -0,0 +1,102 @@
+! { dg-do compile }
+! { dg-options "-fopenmp -fdump-tree-optimized -O0" }
+
+! Check use_device_ptr with local variables
+
+module offloading
+ use iso_c_binding
+ implicit none
+ interface
+ subroutine copy3_array_data(from, to, N) bind(C)
+ import :: c_ptr
+ type(c_ptr), value :: from, to
+ integer, value :: N
+ end subroutine copy3_array_data
+ end interface
+end module offloading
+
+subroutine omp_device_ptr()
+ use iso_c_binding
+ use offloading
+ implicit none
+
+ integer, parameter :: N = 1000
+ real(c_double), pointer :: AA(:), BBB(:)
+ real(c_double), allocatable, target :: CC(:), DD(:)
+ real(c_double), target :: EE(N), FF(N), dummy(1)
+
+ ! allocate(AA(N), BBB(N), CC(N), DD(N)) ! make dump more readable
+
+ ! AA = 11.0_c_double
+ ! BBB = 22.0_c_double
+ ! CC = 33.0_c_double
+ ! DD = 44.0_c_double
+ ! EE = 55.0_c_double
+ ! FF = 66.0_c_double
+
+ ! NOTE: OpenMP 5's use_device_addr is (at time of writing) not yet supported
+
+ ! pointer-type array to use_device_ptr
+ ! !$omp target data map(to:AA) map(from:BBB) use_device_ptr(AA,BBB)
+ !$omp target data map(alloc:dummy) use_device_ptr(AA,BBB)
+ call copy3_array_data(c_loc(AA), c_loc(BBB), N)
+ !$omp end target data
+
+ ! allocatable array to use_device_ptr
+ !!$omp target data map(to:CC) map(from:DD) use_device_ptr(CC,DD)
+ !$omp target data map(alloc:dummy) use_device_ptr(CC,DD)
+ call copy3_array_data(c_loc(CC), c_loc(DD), N)
+ !$omp end target data
+
+ ! fixed-size decriptorless array to use_device_ptr
+ !!$omp target data map(to:EE) map(from:FF) use_device_ptr(EE,FF)
+ !$omp target data map(alloc:dummy) use_device_ptr(EE,FF)
+ call copy3_array_data(c_loc(EE), c_loc(FF), N)
+ !$omp end target data
+
+ ! deallocate(AA, BBB) ! Free all pointers, only
+end subroutine omp_device_ptr
+
+
+! { dg-final { scan-tree-dump-not ".omp_data_arr.\[0-9\]+.aa = &aa" "optimized" } }
+! { dg-final { scan-tree-dump-not ".omp_data_arr.\[0-9\]+.aa = aa" "optimized" } }
+! { dg-final { scan-tree-dump-not ".omp_data_arr.\[0-9\]+.bbb = &bbb" "optimized" } }
+! { dg-final { scan-tree-dump-not ".omp_data_arr.\[0-9\]+.bbb = bbb" "optimized" } }
+! { dg-final { scan-tree-dump-not ".omp_data_arr.\[0-9\]+.cc = &cc" "optimized" } }
+! { dg-final { scan-tree-dump-not ".omp_data_arr.\[0-9\]+.cc = cc" "optimized" } }
+! { dg-final { scan-tree-dump-not ".omp_data_arr.\[0-9\]+.dd = &dd" "optimized" } }
+! { dg-final { scan-tree-dump-not ".omp_data_arr.\[0-9\]+.dd = dd" "optimized" } }
+! { dg-final { scan-tree-dump-not ".omp_data_arr.\[0-9\]+.ee = ee" "optimized" } }
+! { dg-final { scan-tree-dump-not ".omp_data_arr.\[0-9\]+.ff = ff" "optimized" } }
+! { dg-final { scan-tree-dump-times ".omp_data_arr.\[0-9\]+.ee = &ee" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times ".omp_data_arr.\[0-9\]+.ff = &ff" 1 "optimized" } }
+
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = aa.data;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "aa\.\[0-9\]+ = aa;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "aa\.\[0-9\]+\.data = _\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = aa\.\[0-9\]+\.data;" 1 "optimized" } }
+
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = bbb.data;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "bbb\.\[0-9\]+ = bbb;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "bbb\.\[0-9\]+\.data = _\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = bbb\.\[0-9\]+\.data;" 1 "optimized" } }
+
+! '3' because of automatic deallocation
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = cc.data;" 3 "optimized" } }
+! { dg-final { scan-tree-dump-times "cc\.\[0-9\]+ = cc;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "cc\.\[0-9\]+\.data = _\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = cc\.\[0-9\]+\.data;" 1 "optimized" } }
+
+! '3' because of automatic deallocation
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = dd.data;" 3 "optimized" } }
+! { dg-final { scan-tree-dump-times "dd\.\[0-9\]+ = dd;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "dd\.\[0-9\]+\.data = _\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = dd\.\[0-9\]+\.data;" 1 "optimized" } }
+
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = .omp_data_arr.\[0-9\]+.ee;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "ee\.\[0-9\]+_\[0-9\]+ = _\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = &\\\(\\*ee.\[0-9\]+_\[0-9\]+\\\);" 1 "optimized" } }
+
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = .omp_data_arr.\[0-9\]+.ff;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "ff\.\[0-9\]+_\[0-9\]+ = _\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = &\\\(\\*ff.\[0-9\]+_\[0-9\]+\\\);" 1 "optimized" } }
new file mode 100644
@@ -0,0 +1,107 @@
+! { dg-do compile }
+! { dg-options "-fopenmp -fdump-tree-optimized -O0" }
+
+! Check use_device_ptr with nonoptional dummy arguments
+
+module offloading
+ use iso_c_binding
+ implicit none
+ interface
+ subroutine copy3_array_data(from, to, N) bind(C)
+ import :: c_ptr
+ type(c_ptr), value :: from, to
+ integer, value :: N
+ end subroutine copy3_array_data
+ end interface
+end module offloading
+
+subroutine omp_device_ptr(AA, BBB, CC, DD, EE, FF, N)
+ use iso_c_binding
+ use offloading
+ implicit none
+
+ integer, value :: N
+ real(c_double), pointer :: AA(:), BBB(:)
+ real(c_double), allocatable, target :: CC(:), DD(:)
+ real(c_double), target :: EE(N), FF(N), dummy(1)
+
+ ! allocate(AA(N), BBB(N), CC(N), DD(N)) ! make dump more readable
+
+ ! AA = 11.0_c_double
+ ! BBB = 22.0_c_double
+ ! CC = 33.0_c_double
+ ! DD = 44.0_c_double
+ ! EE = 55.0_c_double
+ ! FF = 66.0_c_double
+
+ ! NOTE: OpenMP 5's use_device_addr is (at time of writing) not yet supported
+
+ ! pointer-type array to use_device_ptr
+ ! !$omp target data map(to:AA) map(from:BBB) use_device_ptr(AA,BBB)
+ !$omp target data map(alloc:dummy) use_device_ptr(AA,BBB)
+ call copy3_array_data(c_loc(AA), c_loc(BBB), N)
+ !$omp end target data
+
+ ! allocatable array to use_device_ptr
+ !!$omp target data map(to:CC) map(from:DD) use_device_ptr(CC,DD)
+ !$omp target data map(alloc:dummy) use_device_ptr(CC,DD)
+ call copy3_array_data(c_loc(CC), c_loc(DD), N)
+ !$omp end target data
+
+ ! fixed-size decriptorless array to use_device_ptr
+ !!$omp target data map(to:EE) map(from:FF) use_device_ptr(EE,FF)
+ !$omp target data map(alloc:dummy) use_device_ptr(EE,FF)
+ call copy3_array_data(c_loc(EE), c_loc(FF), N)
+ !$omp end target data
+
+ ! deallocate(AA, BBB) ! Free all pointers, only
+end subroutine omp_device_ptr
+
+! { dg-final { scan-tree-dump-not ".omp_data_arr.aa" "optimized" } }
+! { dg-final { scan-tree-dump-not ".omp_data_arr.\[0-9\]+.aa" "optimized" } }
+! { dg-final { scan-tree-dump-not ".omp_data_arr.bbb" "optimized" } }
+! { dg-final { scan-tree-dump-not ".omp_data_arr.\[0-9\]+.bbb" "optimized" } }
+! { dg-final { scan-tree-dump-not ".omp_data_arr.cc" "optimized" } }
+! { dg-final { scan-tree-dump-not ".omp_data_arr.\[0-9\]+.cc" "optimized" } }
+! { dg-final { scan-tree-dump-not ".omp_data_arr.dd" "optimized" } }
+! { dg-final { scan-tree-dump-not ".omp_data_arr.\[0-9\]+.dd" "optimized" } }
+
+! { dg-final { scan-tree-dump-times ".omp_data_arr.\[0-9\]+.D.\[0-9\]+ = _\[0-9\]+" 4 "optimized" } }
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = .omp_data_arr.\[0-9\]+.D.\[0-9\]+" 4 "optimized" } }
+! { dg-final { scan-tree-dump-times ".omp_data_arr.\[0-9\]+.ee = ee_\[0-9\]+.D.;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times ".omp_data_arr.\[0-9\]+.ff = ff_\[0-9\]+.D.;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = .omp_data_arr.\[0-9\]+.ee;" 1 "optimized" } }
+
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = aa_\[0-9\]+.D.->data;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = \\*aa_\[0-9\]+.D.;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "aa.\[0-9\]+ = D.\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "aa.\[0-9\]+.data = _\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "aa.\[0-9\]+_\[0-9\]+ = &aa.\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = aa.\[0-9\]+_\[0-9\]+->data;" 1 "optimized" } }
+
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = bbb_\[0-9\]+.D.->data;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = \\*bbb_\[0-9\]+.D.;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "bbb.\[0-9\]+ = D.\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "bbb.\[0-9\]+.data = _\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "bbb.\[0-9\]+_\[0-9\]+ = &bbb.\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = bbb.\[0-9\]+_\[0-9\]+->data;" 1 "optimized" } }
+
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = cc_\[0-9\]+.D.->data;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = \\*cc_\[0-9\]+.D.;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "cc.\[0-9\]+ = D.\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "cc.\[0-9\]+.data = _\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "cc.\[0-9\]+_\[0-9\]+ = &cc.\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = cc.\[0-9\]+_\[0-9\]+->data;" 1 "optimized" } }
+
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = dd_\[0-9\]+.D.->data;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = \\*dd_\[0-9\]+.D.;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "dd.\[0-9\]+ = D.\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "dd.\[0-9\]+.data = _\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "dd.\[0-9\]+_\[0-9\]+ = &dd.\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = dd.\[0-9\]+_\[0-9\]+->data;" 1 "optimized" } }
+
+! { dg-final { scan-tree-dump-times "ee.\[0-9\]+_\[0-9\]+ = _\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = ee.\[0-9\]+_\[0-9\]+" 1 "optimized" } }
+
+! { dg-final { scan-tree-dump-times "ff.\[0-9\]+_\[0-9\]+ = _\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = ff.\[0-9\]+_\[0-9\]+" 1 "optimized" } }
new file mode 100644
@@ -0,0 +1,108 @@
+! { dg-do compile }
+! { dg-options "-fopenmp -fdump-tree-optimized -O0" }
+
+! Check use_device_ptr with optional dummy arguments
+
+module offloading
+ use iso_c_binding
+ implicit none
+ interface
+ subroutine copy3_array_data(from, to, N) bind(C)
+ import :: c_ptr
+ type(c_ptr), value :: from, to
+ integer, value :: N
+ end subroutine copy3_array_data
+ end interface
+end module offloading
+
+subroutine omp_device_ptr(AA, BBB, CC, DD, EE, FF, N)
+ use iso_c_binding
+ use offloading
+ implicit none
+
+ integer, value :: N
+ real(c_double), optional, pointer :: AA(:), BBB(:)
+ real(c_double), optional, allocatable, target :: CC(:), DD(:)
+ real(c_double), optional, target :: EE(N), FF(N)
+ real(c_double) :: dummy(1)
+
+ ! allocate(AA(N), BBB(N), CC(N), DD(N)) ! make dump more readable
+
+ ! AA = 11.0_c_double
+ ! BBB = 22.0_c_double
+ ! CC = 33.0_c_double
+ ! DD = 44.0_c_double
+ ! EE = 55.0_c_double
+ ! FF = 66.0_c_double
+
+ ! NOTE: OpenMP 5's use_device_addr is (at time of writing) not yet supported
+
+ ! pointer-type array to use_device_ptr
+ ! !$omp target data map(to:AA) map(from:BBB) use_device_ptr(AA,BBB)
+ !$omp target data map(alloc:dummy) use_device_ptr(AA,BBB)
+ call copy3_array_data(c_loc(AA), c_loc(BBB), N)
+ !$omp end target data
+
+ ! allocatable array to use_device_ptr
+ !!$omp target data map(to:CC) map(from:DD) use_device_ptr(CC,DD)
+ !$omp target data map(alloc:dummy) use_device_ptr(CC,DD)
+ call copy3_array_data(c_loc(CC), c_loc(DD), N)
+ !$omp end target data
+
+ ! fixed-size decriptorless array to use_device_ptr
+ !!$omp target data map(to:EE) map(from:FF) use_device_ptr(EE,FF)
+ !$omp target data map(alloc:dummy) use_device_ptr(EE,FF)
+ call copy3_array_data(c_loc(EE), c_loc(FF), N)
+ !$omp end target data
+
+ ! deallocate(AA, BBB) ! Free all pointers, only
+end subroutine omp_device_ptr
+
+! { dg-final { scan-tree-dump-not ".omp_data_arr.aa" "optimized" } }
+! { dg-final { scan-tree-dump-not ".omp_data_arr.\[0-9\]+.aa" "optimized" } }
+! { dg-final { scan-tree-dump-not ".omp_data_arr.bbb" "optimized" } }
+! { dg-final { scan-tree-dump-not ".omp_data_arr.\[0-9\]+.bbb" "optimized" } }
+! { dg-final { scan-tree-dump-not ".omp_data_arr.cc" "optimized" } }
+! { dg-final { scan-tree-dump-not ".omp_data_arr.\[0-9\]+.cc" "optimized" } }
+! { dg-final { scan-tree-dump-not ".omp_data_arr.dd" "optimized" } }
+! { dg-final { scan-tree-dump-not ".omp_data_arr.\[0-9\]+.dd" "optimized" } }
+
+! { dg-final { scan-tree-dump-times ".omp_data_arr.\[0-9\]+.D.\[0-9\]+ = _\[0-9\]+" 4 "optimized" } }
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = .omp_data_arr.\[0-9\]+.D.\[0-9\]+" 4 "optimized" } }
+! { dg-final { scan-tree-dump-times ".omp_data_arr.\[0-9\]+.ee = ee_\[0-9\]+.D.;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times ".omp_data_arr.\[0-9\]+.ff = ff_\[0-9\]+.D.;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = .omp_data_arr.\[0-9\]+.ee;" 1 "optimized" } }
+
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = aa_\[0-9\]+.D.->data;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = \\*aa_\[0-9\]+.D.;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "aa.\[0-9\]+ = D.\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "aa.\[0-9\]+.data = _\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "aa.\[0-9\]+_\[0-9\]+ = &aa.\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = aa.\[0-9\]+_\[0-9\]+->data;" 1 "optimized" } }
+
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = bbb_\[0-9\]+.D.->data;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = \\*bbb_\[0-9\]+.D.;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "bbb.\[0-9\]+ = D.\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "bbb.\[0-9\]+.data = _\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "bbb.\[0-9\]+_\[0-9\]+ = &bbb.\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = bbb.\[0-9\]+_\[0-9\]+->data;" 1 "optimized" } }
+
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = cc_\[0-9\]+.D.->data;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = \\*cc_\[0-9\]+.D.;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "cc.\[0-9\]+ = D.\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "cc.\[0-9\]+.data = _\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "cc.\[0-9\]+_\[0-9\]+ = &cc.\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = cc.\[0-9\]+_\[0-9\]+->data;" 1 "optimized" } }
+
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = dd_\[0-9\]+.D.->data;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "D.\[0-9\]+ = \\*dd_\[0-9\]+.D.;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "dd.\[0-9\]+ = D.\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "dd.\[0-9\]+.data = _\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "dd.\[0-9\]+_\[0-9\]+ = &dd.\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = dd.\[0-9\]+_\[0-9\]+->data;" 1 "optimized" } }
+
+! { dg-final { scan-tree-dump-times "ee.\[0-9\]+_\[0-9\]+ = _\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = ee.\[0-9\]+_\[0-9\]+" 1 "optimized" } }
+
+! { dg-final { scan-tree-dump-times "ff.\[0-9\]+_\[0-9\]+ = _\[0-9\]+;" 1 "optimized" } }
+! { dg-final { scan-tree-dump-times "_\[0-9\]+ = ff.\[0-9\]+_\[0-9\]+" 1 "optimized" } }
new file mode 100644
@@ -0,0 +1,590 @@
+module offloading
+ use iso_c_binding
+ implicit none
+contains
+ subroutine copy3_array_data_int(from, to, N)
+ !$omp declare target
+ type(c_ptr), value :: from, to
+ integer, value :: N
+
+ real(c_double), pointer :: from_ptr(:)
+ real(c_double), pointer :: to_ptr(:)
+ integer :: i
+
+ call c_f_pointer(from, from_ptr, shape=[N])
+ call c_f_pointer(to, to_ptr, shape=[N])
+ !$omp parallel do
+ do i = 1, N
+ to_ptr(i) = 3 * from_ptr(i)
+ end do
+ !$omp end parallel do
+ end subroutine copy3_array_data_int
+
+ subroutine copy3_array_data(from, to, N)
+ type(c_ptr), value :: from, to
+ integer, value :: N
+ !$omp target is_device_ptr(from, to)
+ call copy3_array_data_int(from, to, N)
+ !$omp end target
+ end subroutine copy3_array_data
+
+ subroutine copy3_array1(from, to)
+ real(c_double), target :: from(:), to(:)
+ integer :: N
+ N = size(from)
+
+ !$omp target is_device_ptr(from, to)
+ call copy3_array_data_int(c_loc(from), c_loc(to), N)
+ !$omp end target
+ end subroutine copy3_array1
+
+! ICE - the following code gives (currently) an ICE
+! It is accepted by the frontend but it is invalid
+! OpenMP 5 as only "a dummy argument that does not have the
+! ALLOCATABLE, POINTER or VALUE attribute."
+!
+! subroutine copy3_array2(from, to)
+! real(c_double), pointer :: from(:), to(:)
+! integer :: N
+! N = size(from)
+!
+! !$omp target is_device_ptr(from, to)
+! call copy3_array_data_int(c_loc(from), c_loc(to), N)
+! !$omp end target
+! end subroutine copy3_array2
+
+ subroutine copy3_array3(from, to)
+ real(c_double), optional, target :: from(:), to(:)
+ integer :: N
+ N = size(from)
+
+ !$omp target is_device_ptr(from, to)
+ call copy3_array_data_int(c_loc(from), c_loc(to), N)
+ !$omp end target
+ end subroutine copy3_array3
+
+! ICE - the following code gives (currently) an ICE
+! It is accepted by the frontend but it is invalid
+! OpenMP 5 as only "a dummy argument that does not have the
+! ALLOCATABLE, POINTER or VALUE attribute."
+!
+! subroutine copy3_array4(from, to)
+! real(c_double), optional, pointer :: from(:), to(:)
+! integer :: N
+! N = size(from)
+!
+! !$omp target is_device_ptr(from, to)
+! call copy3_array_data_int(c_loc(from), c_loc(to), N)
+! !$omp end target
+! end subroutine copy3_array4
+end module offloading
+
+
+
+module offloading2
+ use iso_c_binding
+ use offloading
+ implicit none
+contains
+ ! Same as main program but uses dummy *nonoptional* arguments
+ subroutine use_device_ptr_sub(AA, BB, CC, DD, EE, FF, AptrA, BptrB, N)
+ real(c_double), pointer :: AA(:), BB(:)
+ real(c_double), allocatable, target :: CC(:), DD(:)
+ real(c_double), target :: EE(N), FF(N), dummy(1)
+ real(c_double), pointer :: AptrA(:), BptrB(:)
+ intent(inout) :: AA, BB, CC, DD, EE, FF
+ integer, value :: N
+
+ type(c_ptr) :: tgt_aptr, tgt_bptr, tgt_cptr, tgt_dptr, tgt_eptr, tgt_fptr
+
+ AA = 11.0_c_double
+ BB = 22.0_c_double
+ CC = 33.0_c_double
+ DD = 44.0_c_double
+ EE = 55.0_c_double
+ FF = 66.0_c_double
+
+ ! NOTE: OpenMP 5's use_device_addr is (at time of writing) not yet supported
+
+ ! pointer-type array to use_device_ptr
+ !$omp target data map(to:AA) map(from:BB) use_device_ptr(AA,BB)
+ call copy3_array_data(c_loc(AA), c_loc(BB), N)
+ !$omp end target data
+
+ if (any(abs(AA - 11.0_c_double) > 10.0_c_double * epsilon(AA))) call abort()
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) call abort()
+
+ ! allocatable array to use_device_ptr
+ !$omp target data map(to:CC) map(from:DD) use_device_ptr(CC,DD)
+ call copy3_array_data(c_loc(CC), c_loc(DD), N)
+ !$omp end target data
+
+ if (any(abs(CC - 33.0_c_double) > 10.0_c_double * epsilon(CC))) call abort()
+ if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) call abort()
+
+ ! fixed-size decriptorless array to use_device_ptr
+ !$omp target data map(to:EE) map(from:FF) use_device_ptr(EE,FF)
+ call copy3_array_data(c_loc(EE), c_loc(FF), N)
+ !$omp end target data
+
+ if (any(abs(EE - 55.0_c_double) > 10.0_c_double * epsilon(EE))) call abort()
+ if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) call abort()
+
+
+
+ AA = 111.0_c_double
+ BB = 222.0_c_double
+ CC = 333.0_c_double
+ DD = 444.0_c_double
+ EE = 555.0_c_double
+ FF = 666.0_c_double
+
+ ! pointer-type array to use_device_ptr
+ !$omp target data map(to:AA) map(from:BB)
+ !$omp target data map(alloc:dummy) use_device_ptr(AA,BB)
+ tgt_aptr = c_loc(AA)
+ tgt_bptr = c_loc(BB)
+ AptrA => AA
+ BptrB => BB
+ !$omp end target data
+
+ call copy3_array_data(tgt_aptr, tgt_bptr, N)
+ !$omp target update from(BB)
+ if (any(abs(AA - 111.0_c_double) > 10.0_c_double * epsilon(AA))) call abort()
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) call abort()
+
+ AA = 1111.0_c_double
+ !$omp target update to(AA)
+ call copy3_array_data(tgt_aptr, tgt_bptr, N)
+ !$omp target update from(BB)
+ if (any(abs(AA - 1111.0_c_double) > 10.0_c_double * epsilon(AA))) call abort()
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) call abort()
+
+ ! AprtA tests
+ AA = 7.0_c_double
+ !$omp target update to(AA)
+ call copy3_array_data(c_loc(AptrA), c_loc(BptrB), N)
+ !$omp target update from(BB)
+ if (any(abs(AA - 7.0_c_double) > 10.0_c_double * epsilon(AA))) call abort()
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) call abort()
+
+ AA = 77.0_c_double
+ !$omp target update to(AA)
+ call copy3_array1(AptrA, BptrB)
+ !$omp target update from(BB)
+ if (any(abs(AA - 77.0_c_double) > 10.0_c_double * epsilon(AA))) call abort()
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) call abort()
+
+! AA = 777.0_c_double
+! !$omp target update to(AA)
+! call copy3_array2(AptrA, BptrB)
+! !$omp target update from(BB)
+! if (any(abs(AA - 777.0_c_double) > 10.0_c_double * epsilon(AA))) call abort()
+! if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) call abort()
+
+ AA = 7777.0_c_double
+ !$omp target update to(AA)
+ call copy3_array3(AptrA, BptrB)
+ !$omp target update from(BB)
+ if (any(abs(AA - 7777.0_c_double) > 10.0_c_double * epsilon(AA))) call abort()
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) call abort()
+
+! AA = 77777.0_c_double
+! !$omp target update to(AA)
+! call copy3_array4(AptrA, BptrB)
+! !$omp target update from(BB)
+ !$omp end target data
+!
+! if (any(abs(AA - 77777.0_c_double) > 10.0_c_double * epsilon(AA))) call abort()
+! if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) call abort()
+
+
+
+ ! allocatable array to use_device_ptr
+ !$omp target data map(to:CC) map(from:DD)
+ !$omp target data map(alloc:dummy) use_device_ptr(CC,DD)
+ tgt_cptr = c_loc(CC)
+ tgt_dptr = c_loc(DD)
+ !$omp end target data
+
+ call copy3_array_data(tgt_cptr, tgt_dptr, N)
+ !$omp target update from(DD)
+ if (any(abs(CC - 333.0_c_double) > 10.0_c_double * epsilon(CC))) call abort()
+ if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) call abort()
+
+ CC = 3333.0_c_double
+ !$omp target update to(CC)
+ call copy3_array_data(tgt_cptr, tgt_dptr, N)
+ !$omp target update from(DD)
+ !$omp end target data
+
+ if (any(abs(CC - 3333.0_c_double) > 10.0_c_double * epsilon(CC))) call abort()
+ if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) call abort()
+
+
+
+ ! fixed-size decriptorless array to use_device_ptr
+ !$omp target data map(to:EE) map(from:FF)
+ !$omp target data map(alloc:dummy) use_device_ptr(EE,FF)
+ tgt_eptr = c_loc(EE)
+ tgt_fptr = c_loc(FF)
+ !$omp end target data
+
+ call copy3_array_data(tgt_eptr, tgt_fptr, N)
+ !$omp target update from(FF)
+ if (any(abs(EE - 555.0_c_double) > 10.0_c_double * epsilon(EE))) call abort()
+ if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) call abort()
+
+ EE = 5555.0_c_double
+ !$omp target update to(EE)
+ call copy3_array_data(tgt_eptr, tgt_fptr, N)
+ !$omp target update from(FF)
+ !$omp end target data
+
+ if (any(abs(EE - 5555.0_c_double) > 10.0_c_double * epsilon(EE))) call abort()
+ if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) call abort()
+ end subroutine use_device_ptr_sub
+
+
+
+ ! Same as main program but uses dummy *optional* arguments
+ subroutine use_device_ptr_sub2(AA, BB, CC, DD, EE, FF, AptrA, BptrB, N)
+ real(c_double), optional, pointer :: AA(:), BB(:)
+ real(c_double), optional, allocatable, target :: CC(:), DD(:)
+ real(c_double), optional, target :: EE(N), FF(N)
+ real(c_double), pointer :: AptrA(:), BptrB(:)
+ intent(inout) :: AA, BB, CC, DD, EE, FF
+ real(c_double), target :: dummy(1)
+ integer, value :: N
+
+ type(c_ptr) :: tgt_aptr, tgt_bptr, tgt_cptr, tgt_dptr, tgt_eptr, tgt_fptr
+
+ AA = 11.0_c_double
+ BB = 22.0_c_double
+ CC = 33.0_c_double
+ DD = 44.0_c_double
+ EE = 55.0_c_double
+ FF = 66.0_c_double
+
+ ! NOTE: OpenMP 5's use_device_addr is (at time of writing) not yet supported
+
+ ! pointer-type array to use_device_ptr
+ !$omp target data map(to:AA) map(from:BB) use_device_ptr(AA,BB)
+ call copy3_array_data(c_loc(AA), c_loc(BB), N)
+ !$omp end target data
+
+ if (any(abs(AA - 11.0_c_double) > 10.0_c_double * epsilon(AA))) call abort()
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) call abort()
+
+ ! allocatable array to use_device_ptr
+ !$omp target data map(to:CC) map(from:DD) use_device_ptr(CC,DD)
+ call copy3_array_data(c_loc(CC), c_loc(DD), N)
+ !$omp end target data
+
+ if (any(abs(CC - 33.0_c_double) > 10.0_c_double * epsilon(CC))) call abort()
+ if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) call abort()
+
+ ! fixed-size decriptorless array to use_device_ptr
+ !$omp target data map(to:EE) map(from:FF) use_device_ptr(EE,FF)
+ call copy3_array_data(c_loc(EE), c_loc(FF), N)
+ !$omp end target data
+
+ if (any(abs(EE - 55.0_c_double) > 10.0_c_double * epsilon(EE))) call abort()
+ if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) call abort()
+
+
+
+ AA = 111.0_c_double
+ BB = 222.0_c_double
+ CC = 333.0_c_double
+ DD = 444.0_c_double
+ EE = 555.0_c_double
+ FF = 666.0_c_double
+
+ ! pointer-type array to use_device_ptr
+ !$omp target data map(to:AA) map(from:BB)
+ !$omp target data map(alloc:dummy) use_device_ptr(AA,BB)
+ tgt_aptr = c_loc(AA)
+ tgt_bptr = c_loc(BB)
+ AptrA => AA
+ BptrB => BB
+ !$omp end target data
+
+ call copy3_array_data(tgt_aptr, tgt_bptr, N)
+ !$omp target update from(BB)
+ if (any(abs(AA - 111.0_c_double) > 10.0_c_double * epsilon(AA))) call abort()
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) call abort()
+
+ AA = 1111.0_c_double
+ !$omp target update to(AA)
+ call copy3_array_data(tgt_aptr, tgt_bptr, N)
+ !$omp target update from(BB)
+ if (any(abs(AA - 1111.0_c_double) > 10.0_c_double * epsilon(AA))) call abort()
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) call abort()
+
+ ! AprtA tests
+ AA = 7.0_c_double
+ !$omp target update to(AA)
+ call copy3_array_data(c_loc(AptrA), c_loc(BptrB), N)
+ !$omp target update from(BB)
+ if (any(abs(AA - 7.0_c_double) > 10.0_c_double * epsilon(AA))) call abort()
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) call abort()
+
+ AA = 77.0_c_double
+ !$omp target update to(AA)
+ call copy3_array1(AptrA, BptrB)
+ !$omp target update from(BB)
+ if (any(abs(AA - 77.0_c_double) > 10.0_c_double * epsilon(AA))) call abort()
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) call abort()
+
+! AA = 777.0_c_double
+! !$omp target update to(AA)
+! call copy3_array2(AptrA, BptrB)
+! !$omp target update from(BB)
+! if (any(abs(AA - 777.0_c_double) > 10.0_c_double * epsilon(AA))) call abort()
+! if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) call abort()
+
+ AA = 7777.0_c_double
+ !$omp target update to(AA)
+ call copy3_array3(AptrA, BptrB)
+ !$omp target update from(BB)
+ if (any(abs(AA - 7777.0_c_double) > 10.0_c_double * epsilon(AA))) call abort()
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) call abort()
+
+! AA = 77777.0_c_double
+! !$omp target update to(AA)
+! call copy3_array4(AptrA, BptrB)
+! !$omp target update from(BB)
+ !$omp end target data
+!
+! if (any(abs(AA - 77777.0_c_double) > 10.0_c_double * epsilon(AA))) call abort()
+! if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) call abort()
+
+
+
+ ! allocatable array to use_device_ptr
+ !$omp target data map(to:CC) map(from:DD)
+ !$omp target data map(alloc:dummy) use_device_ptr(CC,DD)
+ tgt_cptr = c_loc(CC)
+ tgt_dptr = c_loc(DD)
+ !$omp end target data
+
+ call copy3_array_data(tgt_cptr, tgt_dptr, N)
+ !$omp target update from(DD)
+ if (any(abs(CC - 333.0_c_double) > 10.0_c_double * epsilon(CC))) call abort()
+ if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) call abort()
+
+ CC = 3333.0_c_double
+ !$omp target update to(CC)
+ call copy3_array_data(tgt_cptr, tgt_dptr, N)
+ !$omp target update from(DD)
+ !$omp end target data
+
+ if (any(abs(CC - 3333.0_c_double) > 10.0_c_double * epsilon(CC))) call abort()
+ if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) call abort()
+
+
+
+ ! fixed-size decriptorless array to use_device_ptr
+ !$omp target data map(to:EE) map(from:FF)
+ !$omp target data map(alloc:dummy) use_device_ptr(EE,FF)
+ tgt_eptr = c_loc(EE)
+ tgt_fptr = c_loc(FF)
+ !$omp end target data
+
+ call copy3_array_data(tgt_eptr, tgt_fptr, N)
+ !$omp target update from(FF)
+ if (any(abs(EE - 555.0_c_double) > 10.0_c_double * epsilon(EE))) call abort()
+ if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) call abort()
+
+ EE = 5555.0_c_double
+ !$omp target update to(EE)
+ call copy3_array_data(tgt_eptr, tgt_fptr, N)
+ !$omp end target data
+
+ if (any(abs(EE - 5555.0_c_double) > 10.0_c_double * epsilon(EE))) call abort()
+ if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) call abort()
+ end subroutine use_device_ptr_sub2
+end module offloading2
+
+
+
+program omp_device_ptr
+ use iso_c_binding
+ use offloading
+ use offloading2
+ implicit none
+
+ integer, parameter :: N = 1000
+ real(c_double), pointer :: AA(:), BB(:), arg_AA(:), arg_BB(:), arg2_AA(:), arg2_BB(:)
+ real(c_double), allocatable, target :: CC(:), DD(:), arg_CC(:), arg_DD(:), arg2_CC(:), arg2_DD(:)
+ real(c_double), target :: EE(N), FF(N), dummy(1), arg_EE(N), arg_FF(N), arg2_EE(N), arg2_FF(N)
+
+ real(c_double), pointer :: AptrA(:), BptrB(:)
+ type(c_ptr) :: tgt_aptr, tgt_bptr, tgt_cptr, tgt_dptr, tgt_eptr, tgt_fptr
+
+ allocate(AA(N), BB(N), CC(N), DD(N))
+
+ AA = 11.0_c_double
+ BB = 22.0_c_double
+ CC = 33.0_c_double
+ DD = 44.0_c_double
+ EE = 55.0_c_double
+ FF = 66.0_c_double
+
+ ! NOTE: OpenMP 5's use_device_addr is (at time of writing) not yet supported
+
+ ! pointer-type array to use_device_ptr
+ !$omp target data map(to:AA) map(from:BB) use_device_ptr(AA,BB)
+ call copy3_array_data(c_loc(AA), c_loc(BB), N)
+ !$omp end target data
+
+ if (any(abs(AA - 11.0_c_double) > 10.0_c_double * epsilon(AA))) call abort()
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) call abort()
+
+ ! allocatable array to use_device_ptr
+ !$omp target data map(to:CC) map(from:DD) use_device_ptr(CC,DD)
+ call copy3_array_data(c_loc(CC), c_loc(DD), N)
+ !$omp end target data
+
+ if (any(abs(CC - 33.0_c_double) > 10.0_c_double * epsilon(CC))) call abort()
+ if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) call abort()
+
+ ! fixed-size decriptorless array to use_device_ptr
+ !$omp target data map(to:EE) map(from:FF) use_device_ptr(EE,FF)
+ call copy3_array_data(c_loc(EE), c_loc(FF), N)
+ !$omp end target data
+
+ if (any(abs(EE - 55.0_c_double) > 10.0_c_double * epsilon(EE))) call abort()
+ if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) call abort()
+
+
+
+ AA = 111.0_c_double
+ BB = 222.0_c_double
+ CC = 333.0_c_double
+ DD = 444.0_c_double
+ EE = 555.0_c_double
+ FF = 666.0_c_double
+
+ ! pointer-type array to use_device_ptr
+ !$omp target data map(to:AA) map(from:BB)
+ !$omp target data map(alloc:dummy) use_device_ptr(AA,BB)
+ tgt_aptr = c_loc(AA)
+ tgt_bptr = c_loc(BB)
+ AptrA => AA
+ BptrB => BB
+ !$omp end target data
+
+ call copy3_array_data(tgt_aptr, tgt_bptr, N)
+ !$omp target update from(BB)
+ if (any(abs(AA - 111.0_c_double) > 10.0_c_double * epsilon(AA))) call abort()
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) call abort()
+
+ AA = 1111.0_c_double
+ !$omp target update to(AA)
+ call copy3_array_data(tgt_aptr, tgt_bptr, N)
+ !$omp target update from(BB)
+ if (any(abs(AA - 1111.0_c_double) > 10.0_c_double * epsilon(AA))) call abort()
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) call abort()
+
+ ! AprtA tests
+ AA = 7.0_c_double
+ !$omp target update to(AA)
+ call copy3_array_data(c_loc(AptrA), c_loc(BptrB), N)
+ !$omp target update from(BB)
+ if (any(abs(AA - 7.0_c_double) > 10.0_c_double * epsilon(AA))) call abort()
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) call abort()
+
+ AA = 77.0_c_double
+ !$omp target update to(AA)
+ call copy3_array1(AptrA, BptrB)
+ !$omp target update from(BB)
+ if (any(abs(AA - 77.0_c_double) > 10.0_c_double * epsilon(AA))) call abort()
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) call abort()
+
+! AA = 777.0_c_double
+! !$omp target update to(AA)
+! call copy3_array2(AptrA, BptrB)
+! !$omp target update from(BB)
+! if (any(abs(AA - 777.0_c_double) > 10.0_c_double * epsilon(AA))) call abort()
+! if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) call abort()
+
+ AA = 7777.0_c_double
+ !$omp target update to(AA)
+ call copy3_array3(AptrA, BptrB)
+ !$omp target update from(BB)
+ if (any(abs(AA - 7777.0_c_double) > 10.0_c_double * epsilon(AA))) call abort()
+ if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) call abort()
+
+! AA = 77777.0_c_double
+! !$omp target update to(AA)
+! call copy3_array4(AptrA, BptrB)
+! !$omp target update from(BB)
+ !$omp end target data
+!
+! if (any(abs(AA - 77777.0_c_double) > 10.0_c_double * epsilon(AA))) call abort()
+! if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) call abort()
+
+
+
+ ! allocatable array to use_device_ptr
+ !$omp target data map(to:CC) map(from:DD)
+ !$omp target data map(alloc:dummy) use_device_ptr(CC,DD)
+ tgt_cptr = c_loc(CC)
+ tgt_dptr = c_loc(DD)
+ !$omp end target data
+
+ call copy3_array_data(tgt_cptr, tgt_dptr, N)
+ !$omp target update from(DD)
+ if (any(abs(CC - 333.0_c_double) > 10.0_c_double * epsilon(CC))) call abort()
+ if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) call abort()
+
+ CC = 3333.0_c_double
+ !$omp target update to(CC)
+ call copy3_array_data(tgt_cptr, tgt_dptr, N)
+ !$omp target update from(DD)
+ !$omp end target data
+
+ if (any(abs(CC - 3333.0_c_double) > 10.0_c_double * epsilon(CC))) call abort()
+ if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) call abort()
+
+
+
+ ! fixed-size decriptorless array to use_device_ptr
+ !$omp target data map(to:EE) map(from:FF)
+ !$omp target data map(alloc:dummy) use_device_ptr(EE,FF)
+ tgt_eptr = c_loc(EE)
+ tgt_fptr = c_loc(FF)
+ !$omp end target data
+
+ call copy3_array_data(tgt_eptr, tgt_fptr, N)
+ !$omp target update from(FF)
+ if (any(abs(EE - 555.0_c_double) > 10.0_c_double * epsilon(EE))) call abort()
+ if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) call abort()
+
+ EE = 5555.0_c_double
+ !$omp target update to(EE)
+ call copy3_array_data(tgt_eptr, tgt_fptr, N)
+ !$omp target update from(FF)
+ !$omp end target data
+
+ if (any(abs(EE - 5555.0_c_double) > 10.0_c_double * epsilon(EE))) call abort()
+ if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) call abort()
+
+
+
+ deallocate(AA, BB) ! Free pointers only
+
+ AptrA => null()
+ BptrB => null()
+ allocate(arg_AA(N), arg_BB(N), arg_CC(N), arg_DD(N))
+ call use_device_ptr_sub(arg_AA, arg_BB, arg_CC, arg_DD, arg_EE, arg_FF, AptrA, BptrB, N)
+ deallocate(arg_AA, arg_BB)
+
+ AptrA => null()
+ BptrB => null()
+ allocate(arg2_AA(N), arg2_BB(N), arg2_CC(N), arg2_DD(N))
+ call use_device_ptr_sub(arg2_AA, arg2_BB, arg2_CC, arg2_DD, arg2_EE, arg2_FF, AptrA, BptrB, N)
+ deallocate(arg2_AA, arg2_BB)
+end program omp_device_ptr