2019-10-31 Tobias Burnus gcc/fortran/ * f95-lang.c (LANG_HOOKS_OMP_ARRAY_DATA): Set to gfc_omp_array_data. * trans-array.c (gfc_conv_descriptor_data_get): Handle also REFERENCE_TYPE. * trans-openmp.c (gfc_omp_array_data): New. * trans.h (gfc_omp_array_data): New prototype. gcc/ * hooks.c (hook_tree_tree_bool_null): New. * hooks.h (hook_tree_tree_bool_null): Declare. * langhooks-def.h (LANG_HOOKS_OMP_ARRAY_DATA): Define. (LANG_HOOKS_DECLS): Add it. * langhooks.h (lang_hooks_for_decls): Add omp_array_data. * omp-low.c (install_var_field): New mode for Fortran descriptor arrays. (lower_omp_target): Handle Fortran array with descriptor in OMP_CLAUSE_USE_DEVICE_ADDR/OMP_CLAUSE_USE_DEVICE_PTR. libgomp/ * testsuite/libgomp.fortran/use_device_addr-1.f90 (test_nullptr_1, test_dummy_opt_nullptr_callee_1): Add present but unallocated test. * testsuite/libgomp.fortran/use_device_addr-2.f90: Likewise. * testsuite/libgomp.fortran/use_device_addr-3.f90: New. * testsuite/libgomp.fortran/use_device_addr-4.f90: New. * testsuite/testsuite/libgomp.fortran/use_device_ptr-1.f90: New. diff --git a/gcc/fortran/f95-lang.c b/gcc/fortran/f95-lang.c index 0f72ab9e3b4..0684c3b99cf 100644 --- a/gcc/fortran/f95-lang.c +++ b/gcc/fortran/f95-lang.c @@ -113,6 +113,7 @@ static const struct attribute_spec gfc_attribute_table[] = #undef LANG_HOOKS_TYPE_FOR_MODE #undef LANG_HOOKS_TYPE_FOR_SIZE #undef LANG_HOOKS_INIT_TS +#undef LANG_HOOKS_OMP_ARRAY_DATA #undef LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR #undef LANG_HOOKS_OMP_IS_OPTIONAL_ARGUMENT #undef LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE @@ -147,6 +148,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_IS_ALLOCATABLE_OR_PTR gfc_omp_is_allocatable_or_ptr #define LANG_HOOKS_OMP_IS_OPTIONAL_ARGUMENT gfc_omp_is_optional_argument #define LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE gfc_omp_privatize_by_reference diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 2d85bf78c42..685f8c5a874 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -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); diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index dad11a24430..aa4f589adc3 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -71,6 +71,33 @@ gfc_omp_is_optional_argument (const_tree decl) && GFC_DECL_OPTIONAL_ARGUMENT (decl)); } + +/* Returns tree with NULL if it is not an array descriptor and with the tree to + access the 'data' component otherwise. With type_only = true, it returns the + TREE_TYPE without creating a new tree. */ + +tree +gfc_omp_array_data (tree decl, bool type_only) +{ + 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 (type_only) + return GFC_TYPE_ARRAY_DATAPTR_TYPE (type); + + 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. */ diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index e96b22acc68..364efe51d7c 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -788,6 +788,7 @@ bool gfc_get_array_descr_info (const_tree, struct array_descr_info *); /* In trans-openmp.c */ bool gfc_omp_is_allocatable_or_ptr (const_tree); bool gfc_omp_is_optional_argument (const_tree); +tree gfc_omp_array_data (tree, bool); bool gfc_omp_privatize_by_reference (const_tree); enum omp_clause_default_kind gfc_omp_predetermined_sharing (tree); tree gfc_omp_report_decl (tree); diff --git a/gcc/hooks.c b/gcc/hooks.c index a9a87de3cdb..8e4578d624d 100644 --- a/gcc/hooks.c +++ b/gcc/hooks.c @@ -429,6 +429,12 @@ hook_tree_tree_int_treep_bool_null (tree, int, tree *, bool) return NULL; } +tree +hook_tree_tree_bool_null (tree, bool) +{ + return NULL; +} + tree hook_tree_tree_tree_null (tree, tree) { diff --git a/gcc/hooks.h b/gcc/hooks.h index 7cfe91d12df..d5269536357 100644 --- a/gcc/hooks.h +++ b/gcc/hooks.h @@ -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_bool_null (tree, bool); 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); diff --git a/gcc/langhooks-def.h b/gcc/langhooks-def.h index 54f80e51f8c..2d3ad9a0a76 100644 --- a/gcc/langhooks-def.h +++ b/gcc/langhooks-def.h @@ -239,6 +239,7 @@ extern tree lhd_unit_size_without_reusable_padding (tree); #define LANG_HOOKS_WARN_UNUSED_GLOBAL_DECL lhd_warn_unused_global_decl #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_IS_ALLOCATABLE_OR_PTR hook_bool_const_tree_false #define LANG_HOOKS_OMP_IS_OPTIONAL_ARGUMENT hook_bool_const_tree_false #define LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE hook_bool_const_tree_false @@ -266,6 +267,7 @@ extern tree lhd_unit_size_without_reusable_padding (tree); LANG_HOOKS_WARN_UNUSED_GLOBAL_DECL, \ LANG_HOOKS_POST_COMPILATION_PARSING_CLEANUPS, \ LANG_HOOKS_DECL_OK_FOR_SIBCALL, \ + LANG_HOOKS_OMP_ARRAY_DATA, \ LANG_HOOKS_OMP_IS_ALLOCATABLE_OR_PTR, \ LANG_HOOKS_OMP_IS_OPTIONAL_ARGUMENT, \ LANG_HOOKS_OMP_PRIVATIZE_BY_REFERENCE, \ diff --git a/gcc/langhooks.h b/gcc/langhooks.h index e50162f9482..39d3608b5f8 100644 --- a/gcc/langhooks.h +++ b/gcc/langhooks.h @@ -226,6 +226,11 @@ struct lang_hooks_for_decls /* True if this decl may be called via a sibcall. */ bool (*ok_for_sibcall) (const_tree); + /* Return a tree for the actual data of an array descriptor - or NULL_TREE + if original tree is not an array descriptor. If the the second argument + is true, only the TREE_TYPE is returned without generating a new tree. */ + tree (*omp_array_data) (tree, bool); + /* 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); diff --git a/gcc/omp-low.c b/gcc/omp-low.c index 279b6ef893a..04e7c504433 100644 --- a/gcc/omp-low.c +++ b/gcc/omp-low.c @@ -715,6 +715,11 @@ 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 & 16) != 0) + { + key = (splay_tree_key) &DECL_NAME (var); + gcc_checking_assert (key != (splay_tree_key) var); + } if ((mask & 8) != 0) { key = (splay_tree_key) &DECL_UID (var); @@ -728,6 +733,9 @@ install_var_field (tree var, bool by_ref, int mask, omp_context *ctx) || !is_gimple_omp_oacc (ctx->stmt)); type = TREE_TYPE (var); + if ((mask & 16) != 0) + type = lang_hooks.decls.omp_array_data (var, true); + /* Prevent redeclaring the var in the split-off function with a restrict pointer type. Note that we only clear type itself, restrict qualifiers in the pointed-to type will be ignored by points-to analysis. */ @@ -752,7 +760,7 @@ install_var_field (tree var, bool by_ref, int mask, omp_context *ctx) 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); @@ -1240,10 +1248,14 @@ 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 - && !omp_is_reference (decl) - && !omp_is_allocatable_or_ptr (decl)) - || TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE) + + /* Fortran array descriptors. */ + if (lang_hooks.decls.omp_array_data (decl, true)) + install_var_field (decl, false, 19, ctx); + else if ((OMP_CLAUSE_CODE (c) == OMP_CLAUSE_USE_DEVICE_ADDR + && !omp_is_reference (decl) + && !omp_is_allocatable_or_ptr (decl)) + || TREE_CODE (TREE_TYPE (decl)) == ARRAY_TYPE) install_var_field (decl, true, 11, ctx); else install_var_field (decl, false, 11, ctx); @@ -11485,7 +11497,8 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx) } else if ((OMP_CLAUSE_CODE (c) == OMP_CLAUSE_USE_DEVICE_ADDR && !omp_is_reference (var) - && !omp_is_allocatable_or_ptr (var)) + && !omp_is_allocatable_or_ptr (var) + && !lang_hooks.decls.omp_array_data (var, true)) || TREE_CODE (TREE_TYPE (var)) == ARRAY_TYPE) { tree new_var = lookup_decl (var, ctx); @@ -11866,7 +11879,14 @@ 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) + + if (lang_hooks.decls.omp_array_data (ovar, true)) + { + tkind = (OMP_CLAUSE_CODE (c) != OMP_CLAUSE_IS_DEVICE_PTR + ? GOMP_MAP_USE_DEVICE_PTR : GOMP_MAP_FIRSTPRIVATE_INT); + x = build_sender_ref ((splay_tree_key) &DECL_NAME (ovar), 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); @@ -11877,10 +11897,12 @@ 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 - && !omp_is_reference (ovar) - && !omp_is_allocatable_or_ptr (ovar)) - || TREE_CODE (type) == ARRAY_TYPE) + if (lang_hooks.decls.omp_array_data (ovar, true)) + var = lang_hooks.decls.omp_array_data (ovar, false); + else if ((OMP_CLAUSE_CODE (c) == OMP_CLAUSE_USE_DEVICE_ADDR + && !omp_is_reference (ovar) + && !omp_is_allocatable_or_ptr (ovar)) + || TREE_CODE (type) == ARRAY_TYPE) var = build_fold_addr_expr (var); else { @@ -12048,11 +12070,50 @@ 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); + bool is_array_data + = lang_hooks.decls.omp_array_data (var, true) != NULL; + 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 (is_array_data + ? (splay_tree_key) &DECL_NAME (var) + : (splay_tree_key) &DECL_UID (var), ctx); else x = build_receiver_ref (var, false, ctx); - if (is_variable_sized (var)) + + if (is_array_data) + { + bool is_ref = omp_is_reference (var); + /* First, we copy the descriptor data from the host; then + we update its data to point to the target address. */ + tree new_var = lookup_decl (var, ctx); + new_var = DECL_VALUE_EXPR (new_var); + tree v = new_var; + + if (is_ref) + { + var = build_fold_indirect_ref (var); + gimplify_expr (&var, &new_body, NULL, is_gimple_val, + fb_rvalue); + v = create_tmp_var_raw (TREE_TYPE (var), get_name (var)); + gimple_add_tmp_var (v); + TREE_ADDRESSABLE (v) = 1; + gimple_seq_add_stmt (&new_body, + gimple_build_assign (v, var)); + tree rhs = build_fold_addr_expr (v); + gimple_seq_add_stmt (&new_body, + gimple_build_assign (new_var, rhs)); + } + else + gimple_seq_add_stmt (&new_body, + gimple_build_assign (new_var, var)); + + tree v2 = lang_hooks.decls.omp_array_data (unshare_expr (v), false); + 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)); + } + else if (is_variable_sized (var)) { tree pvar = DECL_VALUE_EXPR (var); gcc_assert (TREE_CODE (pvar) == INDIRECT_REF); diff --git a/libgomp/testsuite/libgomp.fortran/use_device_addr-1.f90 b/libgomp/testsuite/libgomp.fortran/use_device_addr-1.f90 index 69607e03e88..1183e49f2e4 100644 --- a/libgomp/testsuite/libgomp.fortran/use_device_addr-1.f90 +++ b/libgomp/testsuite/libgomp.fortran/use_device_addr-1.f90 @@ -884,8 +884,10 @@ contains real(c_double), pointer :: aa, bb real(c_double), pointer :: ee, ff - type(c_ptr) :: c_aptr, c_bptr, c_eptr, c_fptr - real(c_double), pointer :: aptr, bptr, eptr, fptr + real(c_double), allocatable, target :: gg, hh + + type(c_ptr) :: c_aptr, c_bptr, c_eptr, c_fptr, c_gptr, c_hptr + real(c_double), pointer :: aptr, bptr, eptr, fptr, gptr, hptr aa => null() bb => null() @@ -905,15 +907,29 @@ contains if (c_associated(c_aptr) .or. c_associated(c_bptr)) stop 1 if (associated(aptr) .or. associated(bptr, bb)) stop 1 - call test_dummy_opt_nullptr_callee_1(ee, ff, c_eptr, c_fptr, eptr, fptr) + if (allocated(gg)) stop 1 + !$omp target data map(tofrom:gg) use_device_addr(gg) + if (c_associated(c_loc(gg))) stop 1 + c_gptr = c_loc(gg) + gptr => gg + if (c_associated(c_gptr)) stop 1 + if (associated(gptr)) stop 1 + if (allocated(gg)) stop 1 + !$omp end target data + if (c_associated(c_gptr)) stop 1 + if (associated(gptr)) stop 1 + if (allocated(gg)) stop 1 + + call test_dummy_opt_nullptr_callee_1(ee, ff, hh, c_eptr, c_fptr, c_hptr, eptr, fptr, hptr) end subroutine test_nullptr_1 - subroutine test_dummy_opt_nullptr_callee_1(ee, ff, c_eptr, c_fptr, eptr, fptr) + subroutine test_dummy_opt_nullptr_callee_1(ee, ff, hh, c_eptr, c_fptr, c_hptr, eptr, fptr, hptr) ! scalars real(c_double), optional, pointer :: ee, ff + real(c_double), optional, allocatable, target :: hh - type(c_ptr), optional :: c_eptr, c_fptr - real(c_double), optional, pointer :: eptr, fptr + type(c_ptr), optional :: c_eptr, c_fptr, c_hptr + real(c_double), optional, pointer :: eptr, fptr, hptr if (.not.present(ee) .or. .not.present(ff)) stop 1 if (associated(ee) .or. associated(ff)) stop 1 @@ -932,6 +948,26 @@ contains if (c_associated(c_eptr) .or. c_associated(c_fptr)) stop 1 if (associated(eptr) .or. associated(fptr)) stop 1 + if (associated(ee) .or. associated(ff)) stop 1 + + + if (.not.present(hh)) stop 1 + if (allocated(hh)) stop 1 + + !$omp target data map(tofrom:hh) use_device_addr(hh) + if (.not.present(hh)) stop 1 + if (allocated(hh)) stop 1 + if (c_associated(c_loc(hh))) stop 1 + c_hptr = c_loc(hh) + hptr => hh + if (c_associated(c_hptr)) stop 1 + if (associated(hptr)) stop 1 + if (allocated(hh)) stop 1 + !$omp end target data + + if (c_associated(c_hptr)) stop 1 + if (associated(hptr)) stop 1 + if (allocated(hh)) stop 1 end subroutine test_dummy_opt_nullptr_callee_1 end module test_nullptr diff --git a/libgomp/testsuite/libgomp.fortran/use_device_addr-2.f90 b/libgomp/testsuite/libgomp.fortran/use_device_addr-2.f90 index 391a8313aec..717689fed1d 100644 --- a/libgomp/testsuite/libgomp.fortran/use_device_addr-2.f90 +++ b/libgomp/testsuite/libgomp.fortran/use_device_addr-2.f90 @@ -884,8 +884,10 @@ contains real(c_float), pointer :: aa, bb real(c_float), pointer :: ee, ff - type(c_ptr) :: c_aptr, c_bptr, c_eptr, c_fptr - real(c_float), pointer :: aptr, bptr, eptr, fptr + real(c_float), allocatable, target :: gg, hh + + type(c_ptr) :: c_aptr, c_bptr, c_eptr, c_fptr, c_gptr, c_hptr + real(c_float), pointer :: aptr, bptr, eptr, fptr, gptr, hptr aa => null() bb => null() @@ -905,15 +907,29 @@ contains if (c_associated(c_aptr) .or. c_associated(c_bptr)) stop 1 if (associated(aptr) .or. associated(bptr, bb)) stop 1 - call test_dummy_opt_nullptr_callee_1(ee, ff, c_eptr, c_fptr, eptr, fptr) + if (allocated(gg)) stop 1 + !$omp target data map(tofrom:gg) use_device_addr(gg) + if (c_associated(c_loc(gg))) stop 1 + c_gptr = c_loc(gg) + gptr => gg + if (c_associated(c_gptr)) stop 1 + if (associated(gptr)) stop 1 + if (allocated(gg)) stop 1 + !$omp end target data + if (c_associated(c_gptr)) stop 1 + if (associated(gptr)) stop 1 + if (allocated(gg)) stop 1 + + call test_dummy_opt_nullptr_callee_1(ee, ff, hh, c_eptr, c_fptr, c_hptr, eptr, fptr, hptr) end subroutine test_nullptr_1 - subroutine test_dummy_opt_nullptr_callee_1(ee, ff, c_eptr, c_fptr, eptr, fptr) + subroutine test_dummy_opt_nullptr_callee_1(ee, ff, hh, c_eptr, c_fptr, c_hptr, eptr, fptr, hptr) ! scalars real(c_float), optional, pointer :: ee, ff + real(c_float), optional, allocatable, target :: hh - type(c_ptr), optional :: c_eptr, c_fptr - real(c_float), optional, pointer :: eptr, fptr + type(c_ptr), optional :: c_eptr, c_fptr, c_hptr + real(c_float), optional, pointer :: eptr, fptr, hptr if (.not.present(ee) .or. .not.present(ff)) stop 1 if (associated(ee) .or. associated(ff)) stop 1 @@ -932,6 +948,26 @@ contains if (c_associated(c_eptr) .or. c_associated(c_fptr)) stop 1 if (associated(eptr) .or. associated(fptr)) stop 1 + if (associated(ee) .or. associated(ff)) stop 1 + + + if (.not.present(hh)) stop 1 + if (allocated(hh)) stop 1 + + !$omp target data map(tofrom:hh) use_device_addr(hh) + if (.not.present(hh)) stop 1 + if (allocated(hh)) stop 1 + if (c_associated(c_loc(hh))) stop 1 + c_hptr = c_loc(hh) + hptr => hh + if (c_associated(c_hptr)) stop 1 + if (associated(hptr)) stop 1 + if (allocated(hh)) stop 1 + !$omp end target data + + if (c_associated(c_hptr)) stop 1 + if (associated(hptr)) stop 1 + if (allocated(hh)) stop 1 end subroutine test_dummy_opt_nullptr_callee_1 end module test_nullptr diff --git a/libgomp/testsuite/libgomp.fortran/use_device_addr-3.f90 b/libgomp/testsuite/libgomp.fortran/use_device_addr-3.f90 new file mode 100644 index 00000000000..6d794d74cb3 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/use_device_addr-3.f90 @@ -0,0 +1,763 @@ +! Comprehensive run-time test for use_device_addr +! +! Tests array with array descriptor +! +! Differs from use_device_addr-4.f90 by using a 8-byte variable (c_double) +! +! This test case assumes that a 'var' appearing in 'use_device_addr' is +! only used as 'c_loc(var)' - such that only the actual data is used/usable +! on the device - and not meta data ((dynamic) type information, 'present()' +! status, array shape). +! +! Untested in this test case are: +! - scalars +! - polymorphic variables +! - absent optional arguments +! +module target_procs + use iso_c_binding + implicit none (type, external) + private + public :: copy3_array +contains + subroutine copy3_array_int(from_ptr, to_ptr, N) + !$omp declare target + real(c_double) :: from_ptr(:) + real(c_double) :: to_ptr(:) + integer, value :: N + integer :: i + + !$omp parallel do + do i = 1, N + to_ptr(i) = 3 * from_ptr(i) + end do + !$omp end parallel do + end subroutine copy3_array_int + + subroutine copy3_array(from, to, N) + type(c_ptr), value :: from, to + integer, value :: N + real(c_double), pointer :: from_ptr(:), to_ptr(:) + + call c_f_pointer(from, from_ptr, shape=[N]) + call c_f_pointer(to, to_ptr, shape=[N]) + + call do_offload_scalar(from_ptr,to_ptr) + contains + subroutine do_offload_scalar(from_r, to_r) + real(c_double), target :: from_r(:), to_r(:) + ! The extra function is needed as is_device_ptr + ! requires non-value, non-pointer dummy arguments + + !$omp target is_device_ptr(from_r, to_r) + call copy3_array_int(from_r, to_r, N) + !$omp end target + end subroutine do_offload_scalar + end subroutine copy3_array +end module target_procs + + + +! Test local dummy arguments (w/o optional) +module test_dummies + use iso_c_binding + use target_procs + implicit none (type, external) + private + public :: test_dummy_call_1, test_dummy_call_2 +contains + subroutine test_dummy_call_1() + integer, parameter :: N = 1000 + + real(c_double), target :: aa(N), bb(N) + real(c_double), target, allocatable :: cc(:), dd(:) + real(c_double), pointer :: ee(:), ff(:) + + allocate(cc(N), dd(N), ee(N), ff(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 + + call test_dummy_callee_1(aa, bb, cc, dd, ee, ff, N) + deallocate(ee, ff) ! pointers, only + end subroutine test_dummy_call_1 + + subroutine test_dummy_callee_1(aa, bb, cc, dd, ee, ff, N) + real(c_double), target :: aa(:), bb(:) + real(c_double), target, allocatable :: cc(:), dd(:) + real(c_double), pointer :: ee(:), ff(:) + + integer, value :: N + + !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb) + call copy3_array(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))) stop 1 + if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 1 + + !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd) + call copy3_array(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))) stop 1 + if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 1 + + !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff) + call copy3_array(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))) stop 1 + if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 1 + end subroutine test_dummy_callee_1 + + ! Save device ptr - and recall pointer + subroutine test_dummy_call_2() + integer, parameter :: N = 1000 + + real(c_double), target :: aa(N), bb(N) + real(c_double), target, allocatable :: cc(:), dd(:) + real(c_double), pointer :: ee(:), ff(:) + + type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr + real(c_double), pointer :: aptr(:), bptr(:), cptr(:), dptr(:), eptr(:), fptr(:) + + allocate(cc(N), dd(N), ee(N), ff(N)) + + call test_dummy_callee_2(aa, bb, cc, dd, ee, ff, & + c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, & + aptr, bptr, cptr, dptr, eptr, fptr, & + N) + deallocate(ee, ff) + end subroutine test_dummy_call_2 + + subroutine test_dummy_callee_2(aa, bb, cc, dd, ee, ff, & + c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, & + aptr, bptr, cptr, dptr, eptr, fptr, & + N) + real(c_double), target :: aa(:), bb(:) + real(c_double), target, allocatable :: cc(:), dd(:) + real(c_double), pointer :: ee(:), ff(:) + + type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr + real(c_double), pointer :: aptr(:), bptr(:), cptr(:), dptr(:), eptr(:), fptr(:) + + integer, value :: N + + real(c_double) :: dummy + + 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 + + !$omp target data map(to:aa) map(from:bb) + !$omp target data map(alloc:dummy) use_device_addr(aa,bb) + c_aptr = c_loc(aa) + c_bptr = c_loc(bb) + aptr => aa + bptr => bb + !$omp end target data + + ! check c_loc ptr once + call copy3_array(c_aptr, c_bptr, N) + !$omp target update from(bb) + if (any(abs(aa - 111.0_c_double) > 10.0_c_double * epsilon(aa))) stop 1 + if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 1 + + ! check c_loc ptr again after target-value modification + aa = 1111.0_c_double + !$omp target update to(aa) + call copy3_array(c_aptr, c_bptr, N) + !$omp target update from(bb) + if (any(abs(aa - 1111.0_c_double) > 10.0_c_double * epsilon(aa))) stop 1 + if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 1 + + ! check Fortran pointer after target-value modification + aa = 11111.0_c_double + !$omp target update to(aa) + call copy3_array(c_loc(aptr), c_loc(bptr), N) + !$omp target update from(bb) + if (any(abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa))) stop 1 + if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 1 + !$omp end target data + + if (any(abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa))) stop 1 + if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 1 + + + !$omp target data map(to:cc) map(from:dd) + !$omp target data map(alloc:dummy) use_device_addr(cc,dd) + c_cptr = c_loc(cc) + c_dptr = c_loc(dd) + cptr => cc + dptr => dd + !$omp end target data + + ! check c_loc ptr once + call copy3_array(c_cptr, c_dptr, N) + !$omp target update from(dd) + if (any(abs(cc - 333.0_c_double) > 10.0_c_double * epsilon(cc))) stop 1 + if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 1 + + ! check c_loc ptr again after target-value modification + cc = 3333.0_c_double + !$omp target update to(cc) + call copy3_array(c_cptr, c_dptr, N) + !$omp target update from(dd) + if (any(abs(cc - 3333.0_c_double) > 10.0_c_double * epsilon(cc))) stop 1 + if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 1 + + ! check Fortran pointer after target-value modification + cc = 33333.0_c_double + !$omp target update to(cc) + call copy3_array(c_loc(cptr), c_loc(dptr), N) + !$omp target update from(dd) + if (any(abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(cc))) stop 1 + if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 1 + !$omp end target data + + if (any(abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(dd))) stop 1 + if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(dd))) stop 1 + + + !$omp target data map(to:ee) map(from:ff) + !$omp target data map(alloc:dummy) use_device_addr(ee,ff) + c_eptr = c_loc(ee) + c_fptr = c_loc(ff) + eptr => ee + fptr => ff + !$omp end target data + + ! check c_loc ptr once + call copy3_array(c_eptr, c_fptr, N) + !$omp target update from(ff) + if (any(abs(ee - 555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 1 + if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 1 + + ! check c_loc ptr again after target-value modification + ee = 5555.0_c_double + !$omp target update to(ee) + call copy3_array(c_eptr, c_fptr, N) + !$omp target update from(ff) + if (any(abs(ee - 5555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 1 + if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 1 + + ! check Fortran pointer after target-value modification + ee = 55555.0_c_double + !$omp target update to(ee) + call copy3_array(c_loc(eptr), c_loc(fptr), N) + !$omp target update from(ff) + if (any(abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 1 + if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ff))) stop 1 + !$omp end target data + + if (any(abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 1 + if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 1 + end subroutine test_dummy_callee_2 +end module test_dummies + + + +! Test local dummy arguments + OPTIONAL +! Values present and ptr associated to nonzero +module test_dummies_opt + use iso_c_binding + use target_procs + implicit none (type, external) + private + public :: test_dummy_opt_call_1, test_dummy_opt_call_2 +contains + subroutine test_dummy_opt_call_1() + integer, parameter :: N = 1000 + + real(c_double), target :: aa(N), bb(N) + real(c_double), target, allocatable :: cc(:), dd(:) + real(c_double), pointer :: ee(:), ff(:) + + allocate(cc(N), dd(N), ee(N), ff(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 + + call test_dummy_opt_callee_1(aa, bb, cc, dd, ee, ff, N) + deallocate(ee, ff) ! pointers, only + end subroutine test_dummy_opt_call_1 + + subroutine test_dummy_opt_callee_1(aa, bb, cc, dd, ee, ff, N) + ! scalars + real(c_double), optional, target :: aa(:), bb(:) + real(c_double), optional, target, allocatable :: cc(:), dd(:) + real(c_double), optional, pointer :: ee(:), ff(:) + + integer, value :: N + + ! All shall be present - and pointing to non-NULL + if (.not.present(aa) .or. .not.present(bb)) stop 1 + if (.not.present(cc) .or. .not.present(dd)) stop 1 + if (.not.present(ee) .or. .not.present(ff)) stop 1 + + if (.not.allocated(cc) .or. .not.allocated(dd)) stop 1 + if (.not.associated(ee) .or. .not.associated(ff)) stop 1 + + !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb) + if (.not.present(aa) .or. .not.present(bb)) stop 1 + if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) stop 1 + call copy3_array(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))) stop 1 + if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 1 + + !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd) + if (.not.present(cc) .or. .not.present(dd)) stop 1 + if (.not.allocated(cc) .or. .not.allocated(dd)) stop 1 + if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) stop 1 + call copy3_array(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))) stop 1 + if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 1 + + !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff) + if (.not.present(ee) .or. .not.present(ff)) stop 1 + if (.not.associated(ee) .or. .not.associated(ff)) stop 1 + if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) stop 1 + call copy3_array(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))) stop 1 + if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 1 + end subroutine test_dummy_opt_callee_1 + + ! Save device ptr - and recall pointer + subroutine test_dummy_opt_call_2() + integer, parameter :: N = 1000 + + real(c_double), target :: aa(N), bb(N) + real(c_double), target, allocatable :: cc(:), dd(:) + real(c_double), pointer :: ee(:), ff(:) + + type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr + real(c_double), pointer :: aptr(:), bptr(:), cptr(:), dptr(:), eptr(:), fptr(:) + + allocate(cc(N), dd(N), ee(N), ff(N)) + call test_dummy_opt_callee_2(aa, bb, cc, dd, ee, ff, & + c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, & + aptr, bptr, cptr, dptr, eptr, fptr, & + N) + deallocate(ee, ff) + end subroutine test_dummy_opt_call_2 + + subroutine test_dummy_opt_callee_2(aa, bb, cc, dd, ee, ff, & + c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, & + aptr, bptr, cptr, dptr, eptr, fptr, & + N) + ! scalars + real(c_double), optional, target :: aa(:), bb(:) + real(c_double), optional, target, allocatable :: cc(:), dd(:) + real(c_double), optional, pointer :: ee(:), ff(:) + + type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr + real(c_double), optional, pointer :: aptr(:), bptr(:), cptr(:), dptr(:), eptr(:), fptr(:) + + integer, value :: N + + real(c_double) :: dummy + + ! All shall be present - and pointing to non-NULL + if (.not.present(aa) .or. .not.present(bb)) stop 1 + if (.not.present(cc) .or. .not.present(dd)) stop 1 + if (.not.present(ee) .or. .not.present(ff)) stop 1 + + if (.not.allocated(cc) .or. .not.allocated(dd)) stop 1 + if (.not.associated(ee) .or. .not.associated(ff)) stop 1 + + 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 + + !$omp target data map(to:aa) map(from:bb) + !$omp target data map(alloc:dummy) use_device_addr(aa,bb) + if (.not.present(aa) .or. .not.present(bb)) stop 1 + if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) stop 1 + c_aptr = c_loc(aa) + c_bptr = c_loc(bb) + aptr => aa + bptr => bb + if (.not.c_associated(c_aptr) .or. .not.c_associated(c_bptr)) stop 1 + if (.not.associated(aptr) .or. .not.associated(bptr)) stop 1 + !$omp end target data + + if (.not.present(aa) .or. .not.present(bb)) stop 1 + if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) stop 1 + if (.not.c_associated(c_aptr) .or. .not.c_associated(c_bptr)) stop 1 + if (.not.associated(aptr) .or. .not.associated(bptr)) stop 1 + + ! check c_loc ptr once + call copy3_array(c_aptr, c_bptr, N) + !$omp target update from(bb) + if (any(abs(aa - 111.0_c_double) > 10.0_c_double * epsilon(aa))) stop 1 + if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 1 + + ! check c_loc ptr again after target-value modification + aa = 1111.0_c_double + !$omp target update to(aa) + call copy3_array(c_aptr, c_bptr, N) + !$omp target update from(bb) + if (any(abs(aa - 1111.0_c_double) > 10.0_c_double * epsilon(aa))) stop 1 + if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 1 + + ! check Fortran pointer after target-value modification + aa = 11111.0_c_double + !$omp target update to(aa) + call copy3_array(c_loc(aptr), c_loc(bptr), N) + !$omp target update from(bb) + if (any(abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa))) stop 1 + if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 1 + !$omp end target data + + if (any(abs(aa - 11111.0_c_double) > 10.0_c_double * epsilon(aa))) stop 1 + if (any(abs(3.0_c_double * aa - bb) > 10.0_c_double * epsilon(aa))) stop 1 + + !$omp target data map(to:cc) map(from:dd) + !$omp target data map(alloc:dummy) use_device_addr(cc,dd) + if (.not.present(cc) .or. .not.present(dd)) stop 1 + if (.not.allocated(cc) .or. .not.allocated(dd)) stop 1 + if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) stop 1 + c_cptr = c_loc(cc) + c_dptr = c_loc(dd) + cptr => cc + dptr => dd + if (.not.c_associated(c_cptr) .or. .not.c_associated(c_dptr)) stop 1 + if (.not.associated(cptr) .or. .not.associated(dptr)) stop 1 + !$omp end target data + if (.not.present(cc) .or. .not.present(dd)) stop 1 + if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) stop 1 + if (.not.c_associated(c_cptr) .or. .not.c_associated(c_dptr)) stop 1 + if (.not.associated(cptr) .or. .not.associated(dptr)) stop 1 + + ! check c_loc ptr once + call copy3_array(c_cptr, c_dptr, N) + !$omp target update from(dd) + if (any(abs(cc - 333.0_c_double) > 10.0_c_double * epsilon(cc))) stop 1 + if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 1 + + ! check c_loc ptr again after target-value modification + cc = 3333.0_c_double + !$omp target update to(cc) + call copy3_array(c_cptr, c_dptr, N) + !$omp target update from(dd) + if (any(abs(cc - 3333.0_c_double) > 10.0_c_double * epsilon(cc))) stop 1 + if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 1 + + ! check Fortran pointer after target-value modification + cc = 33333.0_c_double + !$omp target update to(cc) + call copy3_array(c_loc(cptr), c_loc(dptr), N) + !$omp target update from(dd) + if (any(abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(cc))) stop 1 + if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 1 + !$omp end target data + + if (any(abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(dd))) stop 1 + if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(dd))) stop 1 + + + !$omp target data map(to:ee) map(from:ff) + !$omp target data map(alloc:dummy) use_device_addr(ee,ff) + if (.not.present(ee) .or. .not.present(ff)) stop 1 + if (.not.associated(ee) .or. .not.associated(ff)) stop 1 + if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) stop 1 + c_eptr = c_loc(ee) + c_fptr = c_loc(ff) + eptr => ee + fptr => ff + if (.not.c_associated(c_eptr) .or. .not.c_associated(c_fptr)) stop 1 + if (.not.associated(eptr) .or. .not.associated(fptr)) stop 1 + !$omp end target data + if (.not.present(ee) .or. .not.present(ff)) stop 1 + if (.not.associated(ee) .or. .not.associated(ff)) stop 1 + if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) stop 1 + if (.not.c_associated(c_eptr) .or. .not.c_associated(c_fptr)) stop 1 + if (.not.associated(eptr) .or. .not.associated(fptr)) stop 1 + + ! check c_loc ptr once + call copy3_array(c_eptr, c_fptr, N) + !$omp target update from(ff) + if (any(abs(ee - 555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 1 + if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 1 + + ! check c_loc ptr again after target-value modification + ee = 5555.0_c_double + !$omp target update to(ee) + call copy3_array(c_eptr, c_fptr, N) + !$omp target update from(ff) + if (any(abs(ee - 5555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 1 + if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 1 + + ! check Fortran pointer after target-value modification + ee = 55555.0_c_double + !$omp target update to(ee) + call copy3_array(c_loc(eptr), c_loc(fptr), N) + !$omp target update from(ff) + if (any(abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 1 + if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ff))) stop 1 + !$omp end target data + + if (any(abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 1 + if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 1 + end subroutine test_dummy_opt_callee_2 +end module test_dummies_opt + + + +! Test nullptr +module test_nullptr + use iso_c_binding + implicit none (type, external) + private + public :: test_nullptr_1 +contains + subroutine test_nullptr_1() + real(c_double), pointer :: aa(:), bb(:) + real(c_double), pointer :: ee(:), ff(:) + + real(c_double), allocatable, target :: gg(:), hh(:) + + type(c_ptr) :: c_aptr, c_bptr, c_eptr, c_fptr, c_gptr, c_hptr + real(c_double), pointer :: aptr(:), bptr(:), eptr(:), fptr(:), gptr(:), hptr(:) + + aa => null() + bb => null() + ee => null() + ff => null() + + if (associated(aa) .or. associated(bb)) stop 1 + !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb) + if (c_associated(c_loc(aa)) .or. c_associated(c_loc(bb))) stop 1 + c_aptr = c_loc(aa) + c_bptr = c_loc(bb) + aptr => aa + bptr => bb + if (c_associated(c_aptr) .or. c_associated(c_bptr)) stop 1 + if (associated(aptr) .or. associated(bptr, bb)) stop 1 + if (associated(aa) .or. associated(bb)) stop 1 + !$omp end target data + if (c_associated(c_aptr) .or. c_associated(c_bptr)) stop 1 + if (associated(aptr) .or. associated(bptr, bb)) stop 1 + if (associated(aa) .or. associated(bb)) stop 1 + + if (allocated(gg)) stop 1 + !$omp target data map(tofrom:gg) use_device_addr(gg) + if (c_associated(c_loc(gg))) stop 1 + c_gptr = c_loc(gg) + gptr => gg + if (c_associated(c_gptr)) stop 1 + if (associated(gptr)) stop 1 + if (allocated(gg)) stop 1 + !$omp end target data + if (c_associated(c_gptr)) stop 1 + if (associated(gptr)) stop 1 + if (allocated(gg)) stop 1 + + call test_dummy_opt_nullptr_callee_1(ee, ff, hh, c_eptr, c_fptr, c_hptr, eptr, fptr, hptr) + end subroutine test_nullptr_1 + + subroutine test_dummy_opt_nullptr_callee_1(ee, ff, hh, c_eptr, c_fptr, c_hptr, eptr, fptr, hptr) + ! scalars + real(c_double), optional, pointer :: ee(:), ff(:) + real(c_double), optional, allocatable, target :: hh(:) + + type(c_ptr), optional :: c_eptr, c_fptr, c_hptr + real(c_double), optional, pointer :: eptr(:), fptr(:), hptr(:) + + if (.not.present(ee) .or. .not.present(ff)) stop 1 + if (associated(ee) .or. associated(ff)) stop 1 + + !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff) + if (.not.present(ee) .or. .not.present(ff)) stop 1 + if (associated(ee) .or. associated(ff)) stop 1 + if (c_associated(c_loc(ee)) .or. c_associated(c_loc(ff))) stop 1 + c_eptr = c_loc(ee) + c_fptr = c_loc(ff) + eptr => ee + fptr => ff + if (c_associated(c_eptr) .or. c_associated(c_fptr)) stop 1 + if (associated(eptr) .or. associated(fptr)) stop 1 + !$omp end target data + + if (c_associated(c_eptr) .or. c_associated(c_fptr)) stop 1 + if (associated(eptr) .or. associated(fptr)) stop 1 + + if (allocated(hh)) stop 1 + !$omp target data map(tofrom:hh) use_device_addr(hh) + if (c_associated(c_loc(hh))) stop 1 + c_hptr = c_loc(hh) + hptr => hh + if (c_associated(c_hptr)) stop 1 + if (associated(hptr)) stop 1 + if (allocated(hh)) stop 1 + !$omp end target data + if (c_associated(c_hptr)) stop 1 + if (associated(hptr)) stop 1 + if (allocated(hh)) stop 1 + end subroutine test_dummy_opt_nullptr_callee_1 +end module test_nullptr + + + +! Test local variables +module tests + use iso_c_binding + use target_procs + implicit none (type, external) + private + public :: test_main_1, test_main_2 +contains + ! map + use_device_addr + c_loc + subroutine test_main_1() + integer, parameter :: N = 1000 + + real(c_double), target, allocatable :: cc(:), dd(:) + real(c_double), pointer :: ee(:), ff(:) + + allocate(cc(N), dd(N), ee(N), ff(N)) + + cc = 33.0_c_double + dd = 44.0_c_double + ee = 55.0_c_double + ff = 66.0_c_double + + !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd) + call copy3_array(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))) stop 1 + if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 1 + + !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff) + call copy3_array(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))) stop 1 + if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 1 + + deallocate(ee, ff) ! pointers, only + end subroutine test_main_1 + + ! Save device ptr - and recall pointer + subroutine test_main_2 + integer, parameter :: N = 1000 + + real(c_double), target, allocatable :: cc(:), dd(:) + real(c_double), pointer :: ee(:), ff(:) + + real(c_double) :: dummy + type(c_ptr) :: c_cptr, c_dptr, c_eptr, c_fptr + real(c_double), pointer :: cptr(:), dptr(:), eptr(:), fptr(:) + + allocate(cc(N), dd(N), ee(N), ff(N)) + + cc = 333.0_c_double + dd = 444.0_c_double + ee = 555.0_c_double + ff = 666.0_c_double + + !$omp target data map(to:cc) map(from:dd) + !$omp target data map(alloc:dummy) use_device_addr(cc,dd) + c_cptr = c_loc(cc) + c_dptr = c_loc(dd) + cptr => cc + dptr => dd + !$omp end target data + + ! check c_loc ptr once + call copy3_array(c_cptr, c_dptr, N) + !$omp target update from(dd) + if (any(abs(cc - 333.0_c_double) > 10.0_c_double * epsilon(cc))) stop 1 + if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 1 + + ! check c_loc ptr again after target-value modification + cc = 3333.0_c_double + !$omp target update to(cc) + call copy3_array(c_cptr, c_dptr, N) + !$omp target update from(dd) + if (any(abs(cc - 3333.0_c_double) > 10.0_c_double * epsilon(cc))) stop 1 + if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 1 + + ! check Fortran pointer after target-value modification + cc = 33333.0_c_double + !$omp target update to(cc) + call copy3_array(c_loc(cptr), c_loc(dptr), N) + !$omp target update from(dd) + if (any(abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(cc))) stop 1 + if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(cc))) stop 1 + !$omp end target data + + if (any(abs(cc - 33333.0_c_double) > 10.0_c_double * epsilon(dd))) stop 1 + if (any(abs(3.0_c_double * cc - dd) > 10.0_c_double * epsilon(dd))) stop 1 + + + !$omp target data map(to:ee) map(from:ff) + !$omp target data map(alloc:dummy) use_device_addr(ee,ff) + c_eptr = c_loc(ee) + c_fptr = c_loc(ff) + eptr => ee + fptr => ff + !$omp end target data + + ! check c_loc ptr once + call copy3_array(c_eptr, c_fptr, N) + !$omp target update from(ff) + if (any(abs(ee - 555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 1 + if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 1 + + ! check c_loc ptr again after target-value modification + ee = 5555.0_c_double + !$omp target update to(ee) + call copy3_array(c_eptr, c_fptr, N) + !$omp target update from(ff) + if (any(abs(ee - 5555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 1 + if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 1 + + ! check Fortran pointer after target-value modification + ee = 55555.0_c_double + !$omp target update to(ee) + call copy3_array(c_loc(eptr), c_loc(fptr), N) + !$omp target update from(ff) + if (any(abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 1 + if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ff))) stop 1 + !$omp end target data + + if (any(abs(ee - 55555.0_c_double) > 10.0_c_double * epsilon(ee))) stop 1 + if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 1 + + deallocate(ee, ff) + end subroutine test_main_2 +end module tests + + +program omp_device_addr + use tests + use test_dummies + use test_dummies_opt + use test_nullptr + implicit none (type, external) + + call test_main_1() + call test_main_2() + + call test_dummy_call_1() + call test_dummy_call_2() + + call test_dummy_opt_call_1() + call test_dummy_opt_call_2() + + call test_nullptr_1() +end program omp_device_addr diff --git a/libgomp/testsuite/libgomp.fortran/use_device_addr-4.f90 b/libgomp/testsuite/libgomp.fortran/use_device_addr-4.f90 new file mode 100644 index 00000000000..32dc92c2ff4 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/use_device_addr-4.f90 @@ -0,0 +1,763 @@ +! Comprehensive run-time test for use_device_addr +! +! Tests array with array descriptor +! +! Differs from use_device_addr-3.f90 by using a 4-byte variable (c_float) +! +! This test case assumes that a 'var' appearing in 'use_device_addr' is +! only used as 'c_loc(var)' - such that only the actual data is used/usable +! on the device - and not meta data ((dynamic) type information, 'present()' +! status, array shape). +! +! Untested in this test case are: +! - scalars +! - polymorphic variables +! - absent optional arguments +! +module target_procs + use iso_c_binding + implicit none (type, external) + private + public :: copy3_array +contains + subroutine copy3_array_int(from_ptr, to_ptr, N) + !$omp declare target + real(c_float) :: from_ptr(:) + real(c_float) :: to_ptr(:) + integer, value :: N + integer :: i + + !$omp parallel do + do i = 1, N + to_ptr(i) = 3 * from_ptr(i) + end do + !$omp end parallel do + end subroutine copy3_array_int + + subroutine copy3_array(from, to, N) + type(c_ptr), value :: from, to + integer, value :: N + real(c_float), pointer :: from_ptr(:), to_ptr(:) + + call c_f_pointer(from, from_ptr, shape=[N]) + call c_f_pointer(to, to_ptr, shape=[N]) + + call do_offload_scalar(from_ptr,to_ptr) + contains + subroutine do_offload_scalar(from_r, to_r) + real(c_float), target :: from_r(:), to_r(:) + ! The extra function is needed as is_device_ptr + ! requires non-value, non-pointer dummy arguments + + !$omp target is_device_ptr(from_r, to_r) + call copy3_array_int(from_r, to_r, N) + !$omp end target + end subroutine do_offload_scalar + end subroutine copy3_array +end module target_procs + + + +! Test local dummy arguments (w/o optional) +module test_dummies + use iso_c_binding + use target_procs + implicit none (type, external) + private + public :: test_dummy_call_1, test_dummy_call_2 +contains + subroutine test_dummy_call_1() + integer, parameter :: N = 1000 + + real(c_float), target :: aa(N), bb(N) + real(c_float), target, allocatable :: cc(:), dd(:) + real(c_float), pointer :: ee(:), ff(:) + + allocate(cc(N), dd(N), ee(N), ff(N)) + + aa = 11.0_c_float + bb = 22.0_c_float + cc = 33.0_c_float + dd = 44.0_c_float + ee = 55.0_c_float + ff = 66.0_c_float + + call test_dummy_callee_1(aa, bb, cc, dd, ee, ff, N) + deallocate(ee, ff) ! pointers, only + end subroutine test_dummy_call_1 + + subroutine test_dummy_callee_1(aa, bb, cc, dd, ee, ff, N) + real(c_float), target :: aa(:), bb(:) + real(c_float), target, allocatable :: cc(:), dd(:) + real(c_float), pointer :: ee(:), ff(:) + + integer, value :: N + + !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb) + call copy3_array(c_loc(aa), c_loc(bb), N) + !$omp end target data + if (any(abs(aa - 11.0_c_float) > 10.0_c_float * epsilon(aa))) stop 1 + if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa))) stop 1 + + !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd) + call copy3_array(c_loc(cc), c_loc(dd), N) + !$omp end target data + if (any(abs(cc - 33.0_c_float) > 10.0_c_float * epsilon(cc))) stop 1 + if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 1 + + !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff) + call copy3_array(c_loc(ee), c_loc(ff), N) + !$omp end target data + if (any(abs(ee - 55.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1 + if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 1 + end subroutine test_dummy_callee_1 + + ! Save device ptr - and recall pointer + subroutine test_dummy_call_2() + integer, parameter :: N = 1000 + + real(c_float), target :: aa(N), bb(N) + real(c_float), target, allocatable :: cc(:), dd(:) + real(c_float), pointer :: ee(:), ff(:) + + type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr + real(c_float), pointer :: aptr(:), bptr(:), cptr(:), dptr(:), eptr(:), fptr(:) + + allocate(cc(N), dd(N), ee(N), ff(N)) + + call test_dummy_callee_2(aa, bb, cc, dd, ee, ff, & + c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, & + aptr, bptr, cptr, dptr, eptr, fptr, & + N) + deallocate(ee, ff) + end subroutine test_dummy_call_2 + + subroutine test_dummy_callee_2(aa, bb, cc, dd, ee, ff, & + c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, & + aptr, bptr, cptr, dptr, eptr, fptr, & + N) + real(c_float), target :: aa(:), bb(:) + real(c_float), target, allocatable :: cc(:), dd(:) + real(c_float), pointer :: ee(:), ff(:) + + type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr + real(c_float), pointer :: aptr(:), bptr(:), cptr(:), dptr(:), eptr(:), fptr(:) + + integer, value :: N + + real(c_float) :: dummy + + aa = 111.0_c_float + bb = 222.0_c_float + cc = 333.0_c_float + dd = 444.0_c_float + ee = 555.0_c_float + ff = 666.0_c_float + + !$omp target data map(to:aa) map(from:bb) + !$omp target data map(alloc:dummy) use_device_addr(aa,bb) + c_aptr = c_loc(aa) + c_bptr = c_loc(bb) + aptr => aa + bptr => bb + !$omp end target data + + ! check c_loc ptr once + call copy3_array(c_aptr, c_bptr, N) + !$omp target update from(bb) + if (any(abs(aa - 111.0_c_float) > 10.0_c_float * epsilon(aa))) stop 1 + if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa))) stop 1 + + ! check c_loc ptr again after target-value modification + aa = 1111.0_c_float + !$omp target update to(aa) + call copy3_array(c_aptr, c_bptr, N) + !$omp target update from(bb) + if (any(abs(aa - 1111.0_c_float) > 10.0_c_float * epsilon(aa))) stop 1 + if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa))) stop 1 + + ! check Fortran pointer after target-value modification + aa = 11111.0_c_float + !$omp target update to(aa) + call copy3_array(c_loc(aptr), c_loc(bptr), N) + !$omp target update from(bb) + if (any(abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa))) stop 1 + if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa))) stop 1 + !$omp end target data + + if (any(abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa))) stop 1 + if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa))) stop 1 + + + !$omp target data map(to:cc) map(from:dd) + !$omp target data map(alloc:dummy) use_device_addr(cc,dd) + c_cptr = c_loc(cc) + c_dptr = c_loc(dd) + cptr => cc + dptr => dd + !$omp end target data + + ! check c_loc ptr once + call copy3_array(c_cptr, c_dptr, N) + !$omp target update from(dd) + if (any(abs(cc - 333.0_c_float) > 10.0_c_float * epsilon(cc))) stop 1 + if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 1 + + ! check c_loc ptr again after target-value modification + cc = 3333.0_c_float + !$omp target update to(cc) + call copy3_array(c_cptr, c_dptr, N) + !$omp target update from(dd) + if (any(abs(cc - 3333.0_c_float) > 10.0_c_float * epsilon(cc))) stop 1 + if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 1 + + ! check Fortran pointer after target-value modification + cc = 33333.0_c_float + !$omp target update to(cc) + call copy3_array(c_loc(cptr), c_loc(dptr), N) + !$omp target update from(dd) + if (any(abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(cc))) stop 1 + if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 1 + !$omp end target data + + if (any(abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(dd))) stop 1 + if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(dd))) stop 1 + + + !$omp target data map(to:ee) map(from:ff) + !$omp target data map(alloc:dummy) use_device_addr(ee,ff) + c_eptr = c_loc(ee) + c_fptr = c_loc(ff) + eptr => ee + fptr => ff + !$omp end target data + + ! check c_loc ptr once + call copy3_array(c_eptr, c_fptr, N) + !$omp target update from(ff) + if (any(abs(ee - 555.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1 + if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 1 + + ! check c_loc ptr again after target-value modification + ee = 5555.0_c_float + !$omp target update to(ee) + call copy3_array(c_eptr, c_fptr, N) + !$omp target update from(ff) + if (any(abs(ee - 5555.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1 + if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 1 + + ! check Fortran pointer after target-value modification + ee = 55555.0_c_float + !$omp target update to(ee) + call copy3_array(c_loc(eptr), c_loc(fptr), N) + !$omp target update from(ff) + if (any(abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1 + if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ff))) stop 1 + !$omp end target data + + if (any(abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1 + if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 1 + end subroutine test_dummy_callee_2 +end module test_dummies + + + +! Test local dummy arguments + OPTIONAL +! Values present and ptr associated to nonzero +module test_dummies_opt + use iso_c_binding + use target_procs + implicit none (type, external) + private + public :: test_dummy_opt_call_1, test_dummy_opt_call_2 +contains + subroutine test_dummy_opt_call_1() + integer, parameter :: N = 1000 + + real(c_float), target :: aa(N), bb(N) + real(c_float), target, allocatable :: cc(:), dd(:) + real(c_float), pointer :: ee(:), ff(:) + + allocate(cc(N), dd(N), ee(N), ff(N)) + + aa = 11.0_c_float + bb = 22.0_c_float + cc = 33.0_c_float + dd = 44.0_c_float + ee = 55.0_c_float + ff = 66.0_c_float + + call test_dummy_opt_callee_1(aa, bb, cc, dd, ee, ff, N) + deallocate(ee, ff) ! pointers, only + end subroutine test_dummy_opt_call_1 + + subroutine test_dummy_opt_callee_1(aa, bb, cc, dd, ee, ff, N) + ! scalars + real(c_float), optional, target :: aa(:), bb(:) + real(c_float), optional, target, allocatable :: cc(:), dd(:) + real(c_float), optional, pointer :: ee(:), ff(:) + + integer, value :: N + + ! All shall be present - and pointing to non-NULL + if (.not.present(aa) .or. .not.present(bb)) stop 1 + if (.not.present(cc) .or. .not.present(dd)) stop 1 + if (.not.present(ee) .or. .not.present(ff)) stop 1 + + if (.not.allocated(cc) .or. .not.allocated(dd)) stop 1 + if (.not.associated(ee) .or. .not.associated(ff)) stop 1 + + !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb) + if (.not.present(aa) .or. .not.present(bb)) stop 1 + if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) stop 1 + call copy3_array(c_loc(aa), c_loc(bb), N) + !$omp end target data + if (any(abs(aa - 11.0_c_float) > 10.0_c_float * epsilon(aa))) stop 1 + if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa))) stop 1 + + !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd) + if (.not.present(cc) .or. .not.present(dd)) stop 1 + if (.not.allocated(cc) .or. .not.allocated(dd)) stop 1 + if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) stop 1 + call copy3_array(c_loc(cc), c_loc(dd), N) + !$omp end target data + if (any(abs(cc - 33.0_c_float) > 10.0_c_float * epsilon(cc))) stop 1 + if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 1 + + !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff) + if (.not.present(ee) .or. .not.present(ff)) stop 1 + if (.not.associated(ee) .or. .not.associated(ff)) stop 1 + if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) stop 1 + call copy3_array(c_loc(ee), c_loc(ff), N) + !$omp end target data + if (any(abs(ee - 55.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1 + if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 1 + end subroutine test_dummy_opt_callee_1 + + ! Save device ptr - and recall pointer + subroutine test_dummy_opt_call_2() + integer, parameter :: N = 1000 + + real(c_float), target :: aa(N), bb(N) + real(c_float), target, allocatable :: cc(:), dd(:) + real(c_float), pointer :: ee(:), ff(:) + + type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr + real(c_float), pointer :: aptr(:), bptr(:), cptr(:), dptr(:), eptr(:), fptr(:) + + allocate(cc(N), dd(N), ee(N), ff(N)) + call test_dummy_opt_callee_2(aa, bb, cc, dd, ee, ff, & + c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, & + aptr, bptr, cptr, dptr, eptr, fptr, & + N) + deallocate(ee, ff) + end subroutine test_dummy_opt_call_2 + + subroutine test_dummy_opt_callee_2(aa, bb, cc, dd, ee, ff, & + c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr, & + aptr, bptr, cptr, dptr, eptr, fptr, & + N) + ! scalars + real(c_float), optional, target :: aa(:), bb(:) + real(c_float), optional, target, allocatable :: cc(:), dd(:) + real(c_float), optional, pointer :: ee(:), ff(:) + + type(c_ptr) :: c_aptr, c_bptr, c_cptr, c_dptr, c_eptr, c_fptr + real(c_float), optional, pointer :: aptr(:), bptr(:), cptr(:), dptr(:), eptr(:), fptr(:) + + integer, value :: N + + real(c_float) :: dummy + + ! All shall be present - and pointing to non-NULL + if (.not.present(aa) .or. .not.present(bb)) stop 1 + if (.not.present(cc) .or. .not.present(dd)) stop 1 + if (.not.present(ee) .or. .not.present(ff)) stop 1 + + if (.not.allocated(cc) .or. .not.allocated(dd)) stop 1 + if (.not.associated(ee) .or. .not.associated(ff)) stop 1 + + aa = 111.0_c_float + bb = 222.0_c_float + cc = 333.0_c_float + dd = 444.0_c_float + ee = 555.0_c_float + ff = 666.0_c_float + + !$omp target data map(to:aa) map(from:bb) + !$omp target data map(alloc:dummy) use_device_addr(aa,bb) + if (.not.present(aa) .or. .not.present(bb)) stop 1 + if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) stop 1 + c_aptr = c_loc(aa) + c_bptr = c_loc(bb) + aptr => aa + bptr => bb + if (.not.c_associated(c_aptr) .or. .not.c_associated(c_bptr)) stop 1 + if (.not.associated(aptr) .or. .not.associated(bptr)) stop 1 + !$omp end target data + + if (.not.present(aa) .or. .not.present(bb)) stop 1 + if (.not.c_associated(c_loc(aa)) .or. .not.c_associated(c_loc(bb))) stop 1 + if (.not.c_associated(c_aptr) .or. .not.c_associated(c_bptr)) stop 1 + if (.not.associated(aptr) .or. .not.associated(bptr)) stop 1 + + ! check c_loc ptr once + call copy3_array(c_aptr, c_bptr, N) + !$omp target update from(bb) + if (any(abs(aa - 111.0_c_float) > 10.0_c_float * epsilon(aa))) stop 1 + if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa))) stop 1 + + ! check c_loc ptr again after target-value modification + aa = 1111.0_c_float + !$omp target update to(aa) + call copy3_array(c_aptr, c_bptr, N) + !$omp target update from(bb) + if (any(abs(aa - 1111.0_c_float) > 10.0_c_float * epsilon(aa))) stop 1 + if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa))) stop 1 + + ! check Fortran pointer after target-value modification + aa = 11111.0_c_float + !$omp target update to(aa) + call copy3_array(c_loc(aptr), c_loc(bptr), N) + !$omp target update from(bb) + if (any(abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa))) stop 1 + if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa))) stop 1 + !$omp end target data + + if (any(abs(aa - 11111.0_c_float) > 10.0_c_float * epsilon(aa))) stop 1 + if (any(abs(3.0_c_float * aa - bb) > 10.0_c_float * epsilon(aa))) stop 1 + + !$omp target data map(to:cc) map(from:dd) + !$omp target data map(alloc:dummy) use_device_addr(cc,dd) + if (.not.present(cc) .or. .not.present(dd)) stop 1 + if (.not.allocated(cc) .or. .not.allocated(dd)) stop 1 + if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) stop 1 + c_cptr = c_loc(cc) + c_dptr = c_loc(dd) + cptr => cc + dptr => dd + if (.not.c_associated(c_cptr) .or. .not.c_associated(c_dptr)) stop 1 + if (.not.associated(cptr) .or. .not.associated(dptr)) stop 1 + !$omp end target data + if (.not.present(cc) .or. .not.present(dd)) stop 1 + if (.not.c_associated(c_loc(cc)) .or. .not.c_associated(c_loc(dd))) stop 1 + if (.not.c_associated(c_cptr) .or. .not.c_associated(c_dptr)) stop 1 + if (.not.associated(cptr) .or. .not.associated(dptr)) stop 1 + + ! check c_loc ptr once + call copy3_array(c_cptr, c_dptr, N) + !$omp target update from(dd) + if (any(abs(cc - 333.0_c_float) > 10.0_c_float * epsilon(cc))) stop 1 + if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 1 + + ! check c_loc ptr again after target-value modification + cc = 3333.0_c_float + !$omp target update to(cc) + call copy3_array(c_cptr, c_dptr, N) + !$omp target update from(dd) + if (any(abs(cc - 3333.0_c_float) > 10.0_c_float * epsilon(cc))) stop 1 + if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 1 + + ! check Fortran pointer after target-value modification + cc = 33333.0_c_float + !$omp target update to(cc) + call copy3_array(c_loc(cptr), c_loc(dptr), N) + !$omp target update from(dd) + if (any(abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(cc))) stop 1 + if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 1 + !$omp end target data + + if (any(abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(dd))) stop 1 + if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(dd))) stop 1 + + + !$omp target data map(to:ee) map(from:ff) + !$omp target data map(alloc:dummy) use_device_addr(ee,ff) + if (.not.present(ee) .or. .not.present(ff)) stop 1 + if (.not.associated(ee) .or. .not.associated(ff)) stop 1 + if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) stop 1 + c_eptr = c_loc(ee) + c_fptr = c_loc(ff) + eptr => ee + fptr => ff + if (.not.c_associated(c_eptr) .or. .not.c_associated(c_fptr)) stop 1 + if (.not.associated(eptr) .or. .not.associated(fptr)) stop 1 + !$omp end target data + if (.not.present(ee) .or. .not.present(ff)) stop 1 + if (.not.associated(ee) .or. .not.associated(ff)) stop 1 + if (.not.c_associated(c_loc(ee)) .or. .not.c_associated(c_loc(ff))) stop 1 + if (.not.c_associated(c_eptr) .or. .not.c_associated(c_fptr)) stop 1 + if (.not.associated(eptr) .or. .not.associated(fptr)) stop 1 + + ! check c_loc ptr once + call copy3_array(c_eptr, c_fptr, N) + !$omp target update from(ff) + if (any(abs(ee - 555.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1 + if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 1 + + ! check c_loc ptr again after target-value modification + ee = 5555.0_c_float + !$omp target update to(ee) + call copy3_array(c_eptr, c_fptr, N) + !$omp target update from(ff) + if (any(abs(ee - 5555.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1 + if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 1 + + ! check Fortran pointer after target-value modification + ee = 55555.0_c_float + !$omp target update to(ee) + call copy3_array(c_loc(eptr), c_loc(fptr), N) + !$omp target update from(ff) + if (any(abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1 + if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ff))) stop 1 + !$omp end target data + + if (any(abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1 + if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 1 + end subroutine test_dummy_opt_callee_2 +end module test_dummies_opt + + + +! Test nullptr +module test_nullptr + use iso_c_binding + implicit none (type, external) + private + public :: test_nullptr_1 +contains + subroutine test_nullptr_1() + real(c_float), pointer :: aa(:), bb(:) + real(c_float), pointer :: ee(:), ff(:) + + real(c_float), allocatable, target :: gg(:), hh(:) + + type(c_ptr) :: c_aptr, c_bptr, c_eptr, c_fptr, c_gptr, c_hptr + real(c_float), pointer :: aptr(:), bptr(:), eptr(:), fptr(:), gptr(:), hptr(:) + + aa => null() + bb => null() + ee => null() + ff => null() + + if (associated(aa) .or. associated(bb)) stop 1 + !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb) + if (c_associated(c_loc(aa)) .or. c_associated(c_loc(bb))) stop 1 + c_aptr = c_loc(aa) + c_bptr = c_loc(bb) + aptr => aa + bptr => bb + if (c_associated(c_aptr) .or. c_associated(c_bptr)) stop 1 + if (associated(aptr) .or. associated(bptr, bb)) stop 1 + if (associated(aa) .or. associated(bb)) stop 1 + !$omp end target data + if (c_associated(c_aptr) .or. c_associated(c_bptr)) stop 1 + if (associated(aptr) .or. associated(bptr, bb)) stop 1 + if (associated(aa) .or. associated(bb)) stop 1 + + if (allocated(gg)) stop 1 + !$omp target data map(tofrom:gg) use_device_addr(gg) + if (c_associated(c_loc(gg))) stop 1 + c_gptr = c_loc(gg) + gptr => gg + if (c_associated(c_gptr)) stop 1 + if (associated(gptr)) stop 1 + if (allocated(gg)) stop 1 + !$omp end target data + if (c_associated(c_gptr)) stop 1 + if (associated(gptr)) stop 1 + if (allocated(gg)) stop 1 + + call test_dummy_opt_nullptr_callee_1(ee, ff, hh, c_eptr, c_fptr, c_hptr, eptr, fptr, hptr) + end subroutine test_nullptr_1 + + subroutine test_dummy_opt_nullptr_callee_1(ee, ff, hh, c_eptr, c_fptr, c_hptr, eptr, fptr, hptr) + ! scalars + real(c_float), optional, pointer :: ee(:), ff(:) + real(c_float), optional, allocatable, target :: hh(:) + + type(c_ptr), optional :: c_eptr, c_fptr, c_hptr + real(c_float), optional, pointer :: eptr(:), fptr(:), hptr(:) + + if (.not.present(ee) .or. .not.present(ff)) stop 1 + if (associated(ee) .or. associated(ff)) stop 1 + + !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff) + if (.not.present(ee) .or. .not.present(ff)) stop 1 + if (associated(ee) .or. associated(ff)) stop 1 + if (c_associated(c_loc(ee)) .or. c_associated(c_loc(ff))) stop 1 + c_eptr = c_loc(ee) + c_fptr = c_loc(ff) + eptr => ee + fptr => ff + if (c_associated(c_eptr) .or. c_associated(c_fptr)) stop 1 + if (associated(eptr) .or. associated(fptr)) stop 1 + !$omp end target data + + if (c_associated(c_eptr) .or. c_associated(c_fptr)) stop 1 + if (associated(eptr) .or. associated(fptr)) stop 1 + + if (allocated(hh)) stop 1 + !$omp target data map(tofrom:hh) use_device_addr(hh) + if (c_associated(c_loc(hh))) stop 1 + c_hptr = c_loc(hh) + hptr => hh + if (c_associated(c_hptr)) stop 1 + if (associated(hptr)) stop 1 + if (allocated(hh)) stop 1 + !$omp end target data + if (c_associated(c_hptr)) stop 1 + if (associated(hptr)) stop 1 + if (allocated(hh)) stop 1 + end subroutine test_dummy_opt_nullptr_callee_1 +end module test_nullptr + + + +! Test local variables +module tests + use iso_c_binding + use target_procs + implicit none (type, external) + private + public :: test_main_1, test_main_2 +contains + ! map + use_device_addr + c_loc + subroutine test_main_1() + integer, parameter :: N = 1000 + + real(c_float), target, allocatable :: cc(:), dd(:) + real(c_float), pointer :: ee(:), ff(:) + + allocate(cc(N), dd(N), ee(N), ff(N)) + + cc = 33.0_c_float + dd = 44.0_c_float + ee = 55.0_c_float + ff = 66.0_c_float + + !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd) + call copy3_array(c_loc(cc), c_loc(dd), N) + !$omp end target data + if (any(abs(cc - 33.0_c_float) > 10.0_c_float * epsilon(cc))) stop 1 + if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 1 + + !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff) + call copy3_array(c_loc(ee), c_loc(ff), N) + !$omp end target data + if (any(abs(ee - 55.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1 + if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 1 + + deallocate(ee, ff) ! pointers, only + end subroutine test_main_1 + + ! Save device ptr - and recall pointer + subroutine test_main_2 + integer, parameter :: N = 1000 + + real(c_float), target, allocatable :: cc(:), dd(:) + real(c_float), pointer :: ee(:), ff(:) + + real(c_float) :: dummy + type(c_ptr) :: c_cptr, c_dptr, c_eptr, c_fptr + real(c_float), pointer :: cptr(:), dptr(:), eptr(:), fptr(:) + + allocate(cc(N), dd(N), ee(N), ff(N)) + + cc = 333.0_c_float + dd = 444.0_c_float + ee = 555.0_c_float + ff = 666.0_c_float + + !$omp target data map(to:cc) map(from:dd) + !$omp target data map(alloc:dummy) use_device_addr(cc,dd) + c_cptr = c_loc(cc) + c_dptr = c_loc(dd) + cptr => cc + dptr => dd + !$omp end target data + + ! check c_loc ptr once + call copy3_array(c_cptr, c_dptr, N) + !$omp target update from(dd) + if (any(abs(cc - 333.0_c_float) > 10.0_c_float * epsilon(cc))) stop 1 + if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 1 + + ! check c_loc ptr again after target-value modification + cc = 3333.0_c_float + !$omp target update to(cc) + call copy3_array(c_cptr, c_dptr, N) + !$omp target update from(dd) + if (any(abs(cc - 3333.0_c_float) > 10.0_c_float * epsilon(cc))) stop 1 + if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 1 + + ! check Fortran pointer after target-value modification + cc = 33333.0_c_float + !$omp target update to(cc) + call copy3_array(c_loc(cptr), c_loc(dptr), N) + !$omp target update from(dd) + if (any(abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(cc))) stop 1 + if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(cc))) stop 1 + !$omp end target data + + if (any(abs(cc - 33333.0_c_float) > 10.0_c_float * epsilon(dd))) stop 1 + if (any(abs(3.0_c_float * cc - dd) > 10.0_c_float * epsilon(dd))) stop 1 + + + !$omp target data map(to:ee) map(from:ff) + !$omp target data map(alloc:dummy) use_device_addr(ee,ff) + c_eptr = c_loc(ee) + c_fptr = c_loc(ff) + eptr => ee + fptr => ff + !$omp end target data + + ! check c_loc ptr once + call copy3_array(c_eptr, c_fptr, N) + !$omp target update from(ff) + if (any(abs(ee - 555.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1 + if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 1 + + ! check c_loc ptr again after target-value modification + ee = 5555.0_c_float + !$omp target update to(ee) + call copy3_array(c_eptr, c_fptr, N) + !$omp target update from(ff) + if (any(abs(ee - 5555.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1 + if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 1 + + ! check Fortran pointer after target-value modification + ee = 55555.0_c_float + !$omp target update to(ee) + call copy3_array(c_loc(eptr), c_loc(fptr), N) + !$omp target update from(ff) + if (any(abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1 + if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ff))) stop 1 + !$omp end target data + + if (any(abs(ee - 55555.0_c_float) > 10.0_c_float * epsilon(ee))) stop 1 + if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 1 + + deallocate(ee, ff) + end subroutine test_main_2 +end module tests + + +program omp_device_addr + use tests + use test_dummies + use test_dummies_opt + use test_nullptr + implicit none (type, external) + + call test_main_1() + call test_main_2() + + call test_dummy_call_1() + call test_dummy_call_2() + + call test_dummy_opt_call_1() + call test_dummy_opt_call_2() + + call test_nullptr_1() +end program omp_device_addr diff --git a/libgomp/testsuite/libgomp.fortran/use_device_ptr-1.f90 b/libgomp/testsuite/libgomp.fortran/use_device_ptr-1.f90 new file mode 100644 index 00000000000..62f09682128 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/use_device_ptr-1.f90 @@ -0,0 +1,595 @@ +module target_procs + use iso_c_binding + implicit none (type, external) + private + public :: copy3_array, copy3_scalar, copy3_array1, copy3_array3 +contains + subroutine copy3_array_int(from_ptr, to_ptr, N) + !$omp declare target + real(c_double) :: from_ptr(:) + real(c_double) :: to_ptr(:) + integer, value :: N + integer :: i + + !$omp parallel do + do i = 1, N + to_ptr(i) = 3 * from_ptr(i) + end do + !$omp end parallel do + end subroutine copy3_array_int + + subroutine copy3_scalar_int(from, to) + !$omp declare target + real(c_double) :: from, to + + to = 3 * from + end subroutine copy3_scalar_int + + + subroutine copy3_array(from, to, N) + type(c_ptr), value :: from, to + integer, value :: N + real(c_double), pointer :: from_ptr(:), to_ptr(:) + + call c_f_pointer(from, from_ptr, shape=[N]) + call c_f_pointer(to, to_ptr, shape=[N]) + + call do_offload_scalar(from_ptr,to_ptr) + contains + subroutine do_offload_scalar(from_r, to_r) + real(c_double), target :: from_r(:), to_r(:) + ! The extra function is needed as is_device_ptr + ! requires non-value, non-pointer dummy arguments + + !$omp target is_device_ptr(from_r, to_r) + call copy3_array_int(from_r, to_r, N) + !$omp end target + end subroutine do_offload_scalar + end subroutine copy3_array + + subroutine copy3_scalar(from, to) + type(c_ptr), value, target :: from, to + real(c_double), pointer :: from_ptr(:), to_ptr(:) + + ! Standard-conform detour of using an array as at time of writing + ! is_device_ptr below does not handle scalars + call c_f_pointer(from, from_ptr, shape=[1]) + call c_f_pointer(to, to_ptr, shape=[1]) + + call do_offload_scalar(from_ptr,to_ptr) + contains + subroutine do_offload_scalar(from_r, to_r) + real(c_double), target :: from_r(:), to_r(:) + ! The extra function is needed as is_device_ptr + ! requires non-value, non-pointer dummy arguments + + !$omp target is_device_ptr(from_r, to_r) + call copy3_scalar_int(from_r(1), to_r(1)) + !$omp end target + end subroutine do_offload_scalar + end subroutine copy3_scalar + + 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(c_loc(from), c_loc(to), N) + !!$omp end target + end subroutine copy3_array1 + + 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(c_loc(from), c_loc(to), N) +! !$omp end target + end subroutine copy3_array3 +end module target_procs + + + +module offloading2 + use iso_c_binding + use target_procs + implicit none (type, external) +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 + + ! pointer-type array to use_device_ptr + !$omp target data map(to:AA) map(from:BB) use_device_ptr(AA,BB) + call copy3_array(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))) stop 1 + if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1 + + ! allocatable array to use_device_ptr + !$omp target data map(to:CC) map(from:DD) use_device_ptr(CC,DD) + call copy3_array(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))) stop 1 + if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) stop 1 + + ! 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(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))) stop 1 + if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) stop 1 + + + + 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(tgt_aptr, tgt_bptr, N) + !$omp target update from(BB) + if (any(abs(AA - 111.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1 + if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1 + + AA = 1111.0_c_double + !$omp target update to(AA) + call copy3_array(tgt_aptr, tgt_bptr, N) + !$omp target update from(BB) + if (any(abs(AA - 1111.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1 + if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1 + + ! AprtA tests + AA = 7.0_c_double + !$omp target update to(AA) + call copy3_array(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))) stop 1 + if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1 + + 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))) stop 1 + if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1 + +! 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))) stop 1 +! if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1 + + 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))) stop 1 + if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1 + +! 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))) stop 1 +! if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1 + + + + ! 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(tgt_cptr, tgt_dptr, N) + !$omp target update from(DD) + if (any(abs(CC - 333.0_c_double) > 10.0_c_double * epsilon(CC))) stop 1 + if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) stop 1 + + CC = 3333.0_c_double + !$omp target update to(CC) + call copy3_array(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))) stop 1 + if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) stop 1 + + + + ! 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(tgt_eptr, tgt_fptr, N) + !$omp target update from(FF) + if (any(abs(EE - 555.0_c_double) > 10.0_c_double * epsilon(EE))) stop 1 + if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) stop 1 + + EE = 5555.0_c_double + !$omp target update to(EE) + call copy3_array(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))) stop 1 + if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) stop 1 + 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 + + ! pointer-type array to use_device_ptr + !$omp target data map(to:AA) map(from:BB) use_device_ptr(AA,BB) + call copy3_array(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))) stop 1 + if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1 + + ! allocatable array to use_device_ptr + !$omp target data map(to:CC) map(from:DD) use_device_ptr(CC,DD) + call copy3_array(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))) stop 1 + if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) stop 1 + + ! 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(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))) stop 1 + if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) stop 1 + + + + 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(tgt_aptr, tgt_bptr, N) + !$omp target update from(BB) + if (any(abs(AA - 111.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1 + if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1 + + AA = 1111.0_c_double + !$omp target update to(AA) + call copy3_array(tgt_aptr, tgt_bptr, N) + !$omp target update from(BB) + if (any(abs(AA - 1111.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1 + if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1 + + ! AprtA tests + AA = 7.0_c_double + !$omp target update to(AA) + call copy3_array(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))) stop 1 + if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1 + + 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))) stop 1 + if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1 + +! 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))) stop 1 +! if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1 + + 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))) stop 1 + if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1 + +! 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))) stop 1 +! if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1 + + + + ! 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(tgt_cptr, tgt_dptr, N) + !$omp target update from(DD) + if (any(abs(CC - 333.0_c_double) > 10.0_c_double * epsilon(CC))) stop 1 + if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) stop 1 + + CC = 3333.0_c_double + !$omp target update to(CC) + call copy3_array(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))) stop 1 + if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) stop 1 + + + + ! 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(tgt_eptr, tgt_fptr, N) + !$omp target update from(FF) + if (any(abs(EE - 555.0_c_double) > 10.0_c_double * epsilon(EE))) stop 1 + if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) stop 1 + + EE = 5555.0_c_double + !$omp target update to(EE) + call copy3_array(tgt_eptr, tgt_fptr, N) + !$omp end target data + + if (any(abs(EE - 5555.0_c_double) > 10.0_c_double * epsilon(EE))) stop 1 + if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) stop 1 + end subroutine use_device_ptr_sub2 +end module offloading2 + + + +program omp_device_ptr + use iso_c_binding + use target_procs + use offloading2 + implicit none (type, external) + + 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 + + ! pointer-type array to use_device_ptr + !$omp target data map(to:AA) map(from:BB) use_device_ptr(AA,BB) + call copy3_array(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))) stop 1 + if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1 + + ! allocatable array to use_device_ptr + !$omp target data map(to:CC) map(from:DD) use_device_ptr(CC,DD) + call copy3_array(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))) stop 1 + if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) stop 1 + + ! 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(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))) stop 1 + if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) stop 1 + + + + 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(tgt_aptr, tgt_bptr, N) + !$omp target update from(BB) + if (any(abs(AA - 111.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1 + if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1 + + AA = 1111.0_c_double + !$omp target update to(AA) + call copy3_array(tgt_aptr, tgt_bptr, N) + !$omp target update from(BB) + if (any(abs(AA - 1111.0_c_double) > 10.0_c_double * epsilon(AA))) stop 1 + if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1 + + ! AprtA tests + AA = 7.0_c_double + !$omp target update to(AA) + call copy3_array(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))) stop 1 + if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1 + + 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))) stop 1 + if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1 + +! 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))) stop 1 +! if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1 + + 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))) stop 1 + if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1 + +! 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))) stop 1 +! if (any(abs(3.0_c_double * AA - BB) > 10.0_c_double * epsilon(AA))) stop 1 + + + + ! 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(tgt_cptr, tgt_dptr, N) + !$omp target update from(DD) + if (any(abs(CC - 333.0_c_double) > 10.0_c_double * epsilon(CC))) stop 1 + if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) stop 1 + + CC = 3333.0_c_double + !$omp target update to(CC) + call copy3_array(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))) stop 1 + if (any(abs(3.0_c_double * CC - DD) > 10.0_c_double * epsilon(CC))) stop 1 + + + + ! 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(tgt_eptr, tgt_fptr, N) + !$omp target update from(FF) + if (any(abs(EE - 555.0_c_double) > 10.0_c_double * epsilon(EE))) stop 1 + if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) stop 1 + + EE = 5555.0_c_double + !$omp target update to(EE) + call copy3_array(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))) stop 1 + if (any(abs(3.0_c_double * EE - FF) > 10.0_c_double * epsilon(EE))) stop 1 + + + + 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_sub2(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