From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 102012 invoked by alias); 14 Oct 2019 13:12:05 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Received: (qmail 101980 invoked by uid 89); 14 Oct 2019 13:12:04 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-20.9 required=5.0 tests=AWL,BAYES_00,GIT_PATCH_0,GIT_PATCH_1,GIT_PATCH_2,GIT_PATCH_3,KAM_SHORT,SUBJ_OBFU_PUNCT_FEW,SUBJ_OBFU_PUNCT_MANY autolearn=ham version=3.3.1 spammy=1763, comprehensive, abs, Comprehensive X-HELO: esa1.mentor.iphmx.com Received: from esa1.mentor.iphmx.com (HELO esa1.mentor.iphmx.com) (68.232.129.153) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Mon, 14 Oct 2019 13:11:53 +0000 IronPort-SDR: zoL08doFojzryz2JU9D6RZaQYmAWpYK34pfnzI7yzvlELEtlWV4G4ew9/Dc90tIYDyOfizOPni StubWDgBwQ2BfUax1JcP0UJZUO6vEezNmCLVu7sl6OevGt9T19sNBTnnSr1QttGe0fZRHYSnMg q6TQmcCJKCGnDoZ6J9GmpUgxyQp93J1lx/c2LqnQsj0mdFS0V9h6bkSDaHYJPjQp7lRdjXrUqN VonsVhijT1dUlUxgLUyJk6hSoiu3OAWawKhA2dBAQZzLayPXrgTfyTI3LhZzS7qIVc01pdpzAq eiY= Received: from orw-gwy-02-in.mentorg.com ([192.94.38.167]) by esa1.mentor.iphmx.com with ESMTP; 14 Oct 2019 05:11:51 -0800 IronPort-SDR: AwMrk2kwoNf9uhbs3N1YGottdP1EAadBUeqlkv1IKbss6XoYXyi1XLkM90eJoeh2XrSnMIUMpF 6JtAhPtGuGFPvomHzhGG7m+HDU4QFm0HCD15VtxiaJnHpY+XtsfLCIKUksw/MuZ8aEwqzTBPlQ WL9f7twagI9amwXPS03rKc2aqSSAN/DNZJJMwpUsRm3RSP0O3dZtEWViMMblAlb+as2h2E3GxL Cqw2hXLhFZ2MgiH4+erh27yoXsbbGJoorm//TUHbRiVzxVLbwZpmKtSryuvqXJyxIixJZYe4lv kqg= To: gcc-patches , fortran , Jakub Jelinek From: Tobias Burnus Subject: [Patch][OpenMP] use_device_addr/use_device_ptr with Fortran allocatable/pointer arrays (= array descriptor) Message-ID: <7b38dcfe-7510-59f1-f6aa-1735abc340c8@codesourcery.com> Date: Mon, 14 Oct 2019 13:17:00 -0000 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:68.0) Gecko/20100101 Thunderbird/68.1.0 MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="------------512A8EFBAE54442620BAC939" Return-Path: tobias@codesourcery.com X-IsSubscribed: yes X-SW-Source: 2019-10/txt/msg00986.txt.bz2 --------------512A8EFBAE54442620BAC939 Content-Type: text/plain; charset="utf-8"; format=flowed Content-Transfer-Encoding: 8bit Content-length: 714 This is a follow-up patch to the use_device_addr work. In particular, it replaces the patch at https://gcc.gnu.org/ml/fortran/2019-09/msg00088.html Fortran array descriptors need special handling, which this patch adds. [The use_device-addr-{3,4} test cases are based on the use_device_addr-{1,2} ones; I saw that I could have tested there optional + deallocated in addition, hence, I added it as well (to all four files). – The use_device-ptr-1.f90 is a slightly cleaned-up version of previous patch and I have removed the compile-time checks of previous patch.] Bootstrapped + regtested on x86_64-gnu-linux w/o "device". And tested additionally the testcases with nvptx offloading. Thanks, Tobias --------------512A8EFBAE54442620BAC939 Content-Type: text/x-patch; charset="UTF-8"; name="use_device_addr_desc.diff" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename="use_device_addr_desc.diff" Content-length: 99846 gcc/fortran/ * f95-lang.c (LANG_HOOKS_OMP_ARRAY_DATA): Set to gfc_omp_array_data. * trans-array.c * trans-openmp.c (gfc_omp_array_data): New. * trans.h (gfc_omp_array_data): New prototype. gcc/ * hooks.c (hook_tree_tree_null): New. * hooks.h (hook_tree_tree_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 (omp_context): Add array_data_map. (delete_omp_context): Free array_data_map. (install_var_field, scan_sharing_clauses, lower_omp_target): Handle Fortran descriptor arrays. 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 437892a6abf..2c4f695ba54 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..42929217eb8 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -71,6 +71,29 @@ 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. */ + +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. */ diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index e96b22acc68..1da0eb96951 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 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..002c7b216d3 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_null (tree) +{ + return NULL; +} + tree hook_tree_tree_tree_null (tree, tree) { diff --git a/gcc/hooks.h b/gcc/hooks.h index 7cfe91d12df..2d7afc6f529 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_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); diff --git a/gcc/langhooks-def.h b/gcc/langhooks-def.h index c5dc83d1cc8..66ac684b74f 100644 --- a/gcc/langhooks-def.h +++ b/gcc/langhooks-def.h @@ -236,6 +236,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_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 @@ -263,6 +264,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 97e3186a41d..ddcbca717ce 100644 --- a/gcc/langhooks.h +++ b/gcc/langhooks.h @@ -222,6 +222,10 @@ 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 of the actual data of an array descriptor - or + NULL_TREE if original tree is not an array descriptor. */ + tree (*omp_array_data) (tree); + /* 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..f56bf11a7bb 100644 --- a/gcc/omp-low.c +++ b/gcc/omp-low.c @@ -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,10 +1248,33 @@ 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) + 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.decls.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) + && !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 +11516,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)) || TREE_CODE (TREE_TYPE (var)) == ARRAY_TYPE) { tree new_var = lookup_decl (var, ctx); @@ -11866,7 +11898,19 @@ 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 = OMP_CLAUSE_CODE (c) != OMP_CLAUSE_IS_DEVICE_PTR + ? GOMP_MAP_USE_DEVICE_PTR : GOMP_MAP_FIRSTPRIVATE_INT; + 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); @@ -11877,10 +11921,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 (n) + var = (tree) n->value; + 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 +12094,56 @@ 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) + { + 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)); + 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 2e5ce60d47c..19da2c5275a 100644 --- a/libgomp/testsuite/libgomp.fortran/use_device_addr-1.f90 +++ b/libgomp/testsuite/libgomp.fortran/use_device_addr-1.f90 @@ -883,8 +883,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() @@ -904,15 +906,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 @@ -931,6 +947,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 bddb4491414..d4fae6439d5 100644 --- a/libgomp/testsuite/libgomp.fortran/use_device_addr-2.f90 +++ b/libgomp/testsuite/libgomp.fortran/use_device_addr-2.f90 @@ -883,8 +883,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() @@ -904,15 +906,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 @@ -931,6 +947,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 --------------512A8EFBAE54442620BAC939--