From patchwork Thu Mar 23 19:57:39 2023 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 74202 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a5d:604a:0:0:0:0:0 with SMTP id j10csp3105148wrt; Thu, 23 Mar 2023 12:58:42 -0700 (PDT) X-Google-Smtp-Source: AKy350YXnFDiA6gmxbwCBEOHt9Ic52mFyGkE0Ki6Arq6MxQ6qVrG0TYUyg9Rqew7X/b5lV8JJpb1 X-Received: by 2002:a05:6402:18:b0:501:cf67:97fc with SMTP id d24-20020a056402001800b00501cf6797fcmr268719edu.10.1679601522537; Thu, 23 Mar 2023 12:58:42 -0700 (PDT) ARC-Seal: i=1; a=rsa-sha256; t=1679601522; cv=none; d=google.com; s=arc-20160816; b=DJIUAiM1qHdTTpVI8L4uYfTHQECc/Ju1BktRYT82ns27LAqyMXV/oCBuL4b8PLOf5q pxQJgjt2u7u1Dyad2J1IdnavAaWGQtGBuvhNPI6DKAn1GbJG0i1JWtKHRjvUyAizzEO8 /Ka156NoBW0ce7JODqiy3cnJ04Vwpry5vfJBWqRfOJjdNbkOR0CB8JzPjMaaOmKjKa3b 2sMfZwxIL5kp4Y85zXNsdQK4HHg9bNYZuw1LZVP4gVmMNH7Iav434MMkjBlHzAakn9UW v7nuQNnKPldHJy1vaUgerxsbpbVndk5fDPYi52v/3Jov+b0dDz8OjcEpg23fJB5m1rnX zJQw== ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=google.com; s=arc-20160816; h=sender:errors-to:list-subscribe:list-help:list-post:list-archive :list-unsubscribe:list-id:precedence:subject:from:to :content-language:user-agent:mime-version:date:message-id :ironport-sdr:dmarc-filter:delivered-to; bh=oGuYC0hBYs5TZxTO0fsGrc0enLSA49MKgjubjDUDr6I=; b=bTIBBbP2w1+C7ljjFYPRbgox3vtfbU3GmSMTPN5/Qg1y0w/BU3JfbsZKnlK9I4tuI8 tBVnkcLJ5NDtHByhKOVXkJP91y/lPa20DDp3sAVwMkIHsVZDepsQmGonyuvq+X7Wp60h NJN16rz46rNjXB5W9yWTkCT7j2nyB+Dt5cOWL+iby3wbXGB3Cmz6ggg18FczO0Y7FVi0 F8McmZveM7HY90Ja+tlAbDs1NyQJR+cs2EHFspEkCZN47Noq747jtuWq/WvH50LpkdJF Agb4gZxz2aZXC6k0usfTvifnGVUI9zAa6E2KetjuSW1RJCdOJ0Oj+m3rYMRDSW7o9T4t M93Q== ARC-Authentication-Results: i=1; mx.google.com; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org" Received: from sourceware.org (server2.sourceware.org. [8.43.85.97]) by mx.google.com with ESMTPS id ay5-20020a056402202500b00501d7cdf513si3692208edb.126.2023.03.23.12.58.42 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Thu, 23 Mar 2023 12:58:42 -0700 (PDT) Received-SPF: pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) client-ip=8.43.85.97; Authentication-Results: mx.google.com; spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 8.43.85.97 as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org" Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 0B0EA38708C6 for ; Thu, 23 Mar 2023 19:58:16 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from esa4.mentor.iphmx.com (esa4.mentor.iphmx.com [68.232.137.252]) by sourceware.org (Postfix) with ESMTPS id CF2C33858C50; Thu, 23 Mar 2023 19:57:46 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org CF2C33858C50 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com X-IronPort-AV: E=Sophos;i="5.98,285,1673942400"; d="diff'?scan'208";a="161510" Received: from orw-gwy-01-in.mentorg.com ([192.94.38.165]) by esa4.mentor.iphmx.com with ESMTP; 23 Mar 2023 11:57:44 -0800 IronPort-SDR: suE/gab7yQLstuHHrWKygriSQQlv4R6EYDKTbw/I1UATNYTyauK9olhMh9d2g3ZRZ0TXQFGPtW l5F7CJS0vlkAsRPUCb0gacptgSGU26gpSRcHaSBYczOK3PvkYwZNYD4kHCzM0j6QnEIqPkHAW/ 1+iwMpMje0d7M4s+dGsqBW1d7pDkjMDbTfYbTQaIR+Xgnhun4smPqITGNMSHZBXPxC+w1PgL6k Cz54ZKE4PTHeuoYMFEYegL2Tbx/ugti52zEPfKwcXkAmY/yCeImukLNSpwda6pupCQvIxOQIMG qiI= Message-ID: <830e6e9d-af1c-31f7-8ec6-9eabe5ebcf9b@codesourcery.com> Date: Thu, 23 Mar 2023 20:57:39 +0100 MIME-Version: 1.0 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:102.0) Gecko/20100101 Thunderbird/102.9.0 Content-Language: en-US To: gcc-patches , fortran From: Tobias Burnus Subject: [OG12][committed] Fortran/OpenMP: Fix 'alloc' and 'from' mapping for allocatable components X-Originating-IP: [137.202.0.90] X-ClientProxiedBy: svr-ies-mbx-12.mgc.mentorg.com (139.181.222.12) To svr-ies-mbx-12.mgc.mentorg.com (139.181.222.12) X-Spam-Status: No, score=-11.3 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, KAM_SHORT, SPF_HELO_PASS, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org Sender: "Gcc-patches" X-getmail-retrieved-from-mailbox: =?utf-8?q?INBOX?= X-GMAIL-THRID: =?utf-8?q?1761189846099687779?= X-GMAIL-MSGID: =?utf-8?q?1761189846099687779?= This is about OpenMP's "deep mapping" of allocatable components of derived types. The basic feature is on OG12 (and OG11) but yet in GCC mainline. The old submissions are at https://gcc.gnu.org/pipermail/gcc-patches/2022-April/593704.html My plan is to get the whole feature into GCC 14 once trunk has opened (and after some simpler pending patches have been merged). It requires some re-diffing to be more digestible. * * * OG12: This patch as been committed to the devel/omp/gcc-12 branch as https://gcc.gnu.org/g:a63735b8034db65a33c359633462accd9d71d3b5 * * * This patch fixes an issue with 'map(alloc:' and 'map(from:' with deep mapping of allocatable components - namely: * For unmapping/coping to the host, the state of unallocated allocatables needs to be preservered. * For mapping to the device ('alloc' and 'from'), we still need to copy data to the device to have the array bounds correctly set. The data pointer (of allocated allocatables) is set as part of allocating memory on the device ('attach'); thus, this part works. As described in the patch (cf. comment above the checking function), we could either copy only the descriptor data (and the NULL for pointers) or we copy everything (shallowly) which includes this data. As there is no means to do the former (without changing the refcount), we do the latter. NOTE: The actual data to which the scalar/array allocatable points to is not 'to' mapped but only 'alloc'. As that is supposed to be the large data, copying everything should™ not cause a large performance penalty with real-world code; it could be even faster than, let's say, copying 5 descriptors separately. OpenMP spec side: It is not completely clear how the OpenMP spec expects the copy out to work. Hence, I filed OpenMP Spec Issue #3545. ----------------- Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955 commit a63735b8034db65a33c359633462accd9d71d3b5 Author: Tobias Burnus Date: Thu Mar 23 18:04:17 2023 +0100 Fortran/OpenMP: Fix 'alloc' and 'from' mapping for allocatable components Even with 'alloc' and map-entering 'from' mapping, the following should hold. For explicit mapping, that's already the case, this handles the automatical deep mapping of allocatable components. Namely: * On the device, the array bounds (of allocated allocatables) must match the host, implying 'to' (or 'tofrom') mapping. * On map exiting, the copying out shall not destroy the unallocated allocation status (nor the pointer address of allocated allocatables). The latter was not a problem for allocated allocatables as for those a pointer was GOMP_MAP_ATTACHed; however, for unallocated allocatables, before it copied back device-allocated memory which might not be nullified. While 'alloc' was not deep-mapped at all, for map-entering 'from', the array bounds were not set, making allocated derived-type components inaccessible on the device (and wrong on the host on copy back). The solution is, first, to deep-map 'alloc' as well and to copy to the device even with 'alloc' and (map-entering) 'from'. This copying is only done if there is a scalar (for the unallocated case) or array allocatable directly in the derived type and then it is shallowly copied; the data pointed to is then again only alloc'ed, unless it contains in turn allocatables. gcc/fortran/ * trans-openmp.cc (gfc_has_alloc_comps): Add 'bool shallow_alloc_only=false' arg. (gfc_omp_replace_alloc_by_to_mapping): New, call it. (gfc_omp_deep_map_kind_p): Return 'true' also for '(present,)alloc'. (gfc_omp_deep_mapping_item, gfc_omp_deep_mapping_do): On map entering, replace shallowly 'alloc'/'from' by '(from)to' mapping if there are allocatable components. libgomp/ * testsuite/libgomp.fortran/map-alloc-comp-8.f90: New test. --- gcc/fortran/ChangeLog.omp | 10 + gcc/fortran/trans-openmp.cc | 96 +++++++- libgomp/ChangeLog.omp | 4 + .../testsuite/libgomp.fortran/map-alloc-comp-8.f90 | 268 +++++++++++++++++++++ 4 files changed, 371 insertions(+), 7 deletions(-) diff --git a/gcc/fortran/ChangeLog.omp b/gcc/fortran/ChangeLog.omp index f7d1f91f178..e3ab2254215 100644 --- a/gcc/fortran/ChangeLog.omp +++ b/gcc/fortran/ChangeLog.omp @@ -1,3 +1,13 @@ +2023-03-23 Tobias Burnus + + * trans-openmp.cc (gfc_has_alloc_comps): Add 'bool + shallow_alloc_only=false' arg. + (gfc_omp_replace_alloc_by_to_mapping): New, call it. + (gfc_omp_deep_map_kind_p): Return 'true' also for '(present,)alloc'. + (gfc_omp_deep_mapping_item, gfc_omp_deep_mapping_do): On map entering, + replace shallowly 'alloc'/'from' by '(from)to' mapping if there are + allocatable components. + 2023-03-23 Tobias Burnus * class.cc (generate_callback_wrapper): Add attr.class_ok check. diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc index 7a94bdcc870..8408d7b5274 100644 --- a/gcc/fortran/trans-openmp.cc +++ b/gcc/fortran/trans-openmp.cc @@ -379,10 +379,13 @@ gfc_omp_report_decl (tree decl) } /* Return true if TYPE has any allocatable components; - if ptr_ok, the decl itself is permitted to have the POINTER attribute. */ + if ptr_ok, the decl itself is permitted to have the POINTER attribute. + if shallow_alloc_only, returns only true if any of the fields is an + allocatable; called with true by gfc_omp_replace_alloc_by_to_mapping. */ static bool -gfc_has_alloc_comps (tree type, tree decl, bool ptr_ok) +gfc_has_alloc_comps (tree type, tree decl, bool ptr_ok, + bool shallow_alloc_only=false) { tree field, ftype; @@ -415,12 +418,50 @@ gfc_has_alloc_comps (tree type, tree decl, bool ptr_ok) if (GFC_DESCRIPTOR_TYPE_P (ftype) && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) return true; - if (gfc_has_alloc_comps (ftype, field, false)) + if (!shallow_alloc_only + && gfc_has_alloc_comps (ftype, field, false)) return true; } return false; } +/* gfc_omp_replace_alloc_by_to_mapping is used with gfc_omp_deep_mapping... to + handle the following: + + For map(alloc: dt), the array descriptors of allocatable components should + be mapped as 'to'; this could be done by (A) adding 'map(to: dt%alloc_comp)' + for each component (and avoiding to increment the reference count). + Or (B) by just mapping all of 'dt' as 'to'. + + If 'dt' contains several allocatable components and not much other data, + (A) is more efficient. If 'dt' contains a large const-size array, (A) will + copy it to the device instead of only 'alloc'ating it. + + IMPLEMENTATION CHOICE: We do (A). It avoids the ref-count issue and it is + expected that, for real-world code, derived types with allocatable + components only have few other components and either no const-size arrays. + This copying is done irrespectively whether the allocatables are allocated. + + If users wanted to save memory, they have to use 'map(alloc:dt%comp)' as + also with 'map(alloc:dt)' all components get copied. + + For the copy to the device, only allocatable arrays are relevant as their + the bounds are required; the pointer is set separately (GOMP_MAP_ATTACH) + and the only setting required for scalars. However, when later copying out + of the device, an unallocated allocatable must remain unallocated/NULL on + the host; to achieve this we also must have it set to NULL on the device + to avoid issues with uninitialized memory being copied back for the pointer + address. If we could set the pointer to NULL, gfc_has_alloc_comps's + shallow_alloc_only could be restricted to return true only for arrays. + + We only need to return true if there are allocatable-array components. */ + +static bool +gfc_omp_replace_alloc_by_to_mapping (tree type, tree decl, bool ptr_ok) +{ + return gfc_has_alloc_comps (type, decl, ptr_ok, true); +} + /* Return true if TYPE is polymorphic but not with pointer attribute. */ static bool @@ -2730,7 +2771,15 @@ gfc_omp_deep_mapping_item (bool is_cnt, bool do_copy, bool do_alloc_check, tmp = gfc_conv_descriptor_data_get (tmp); } - gfc_omp_deep_mapping_map (tmp, bytesize, tkind, loc, data_array, + /* For polymorphic, a extended type may have allocatable components; + see comment before gfc_omp_replace_alloc_by_to_mapping. */ + unsigned HOST_WIDE_INT tkind2 = tkind; + if (tkind == GOMP_MAP_ALLOC) + tkind2 = GOMP_MAP_TO; + else if (tkind == GOMP_MAP_FROM + && gimple_omp_target_kind (ctx) != GF_OMP_TARGET_KIND_EXIT_DATA) + tkind2 = GOMP_MAP_TOFROM; + gfc_omp_deep_mapping_map (tmp, bytesize, tkind2, loc, data_array, sizes_array, kinds_array, offset_data, offset, seq, ctx); } @@ -2755,7 +2804,16 @@ gfc_omp_deep_mapping_item (bool is_cnt, bool do_copy, bool do_alloc_check, tmp = decl; bytesize = TYPE_SIZE_UNIT (TREE_TYPE (decl)); } - gfc_omp_deep_mapping_map (tmp, bytesize, tkind, loc, data_array, + unsigned HOST_WIDE_INT tkind2 = tkind; + if (!is_cnt + && (tkind == GOMP_MAP_ALLOC + || (tkind == GOMP_MAP_FROM + && (gimple_omp_target_kind (ctx) + != GF_OMP_TARGET_KIND_EXIT_DATA))) + && gfc_omp_replace_alloc_by_to_mapping (TREE_TYPE (decl), decl, true)) + tkind2 = tkind == GOMP_MAP_ALLOC ? GOMP_MAP_TO : GOMP_MAP_TOFROM; + + gfc_omp_deep_mapping_map (tmp, bytesize, tkind2, loc, data_array, sizes_array, kinds_array, offset_data, offset, seq, ctx); } @@ -2889,9 +2947,9 @@ gfc_omp_deep_map_kind_p (tree clause) case GOMP_MAP_ALWAYS_PRESENT_FROM: case GOMP_MAP_ALWAYS_PRESENT_TOFROM: case GOMP_MAP_FIRSTPRIVATE: - return true; case GOMP_MAP_ALLOC: case GOMP_MAP_PRESENT_ALLOC: + return true; case GOMP_MAP_POINTER: case GOMP_MAP_TO_PSET: case GOMP_MAP_FORCE_PRESENT: @@ -3004,6 +3062,21 @@ gfc_omp_deep_mapping_do (bool is_cnt, const gimple *ctx, tree clause, tree decl = gfc_omp_deep_mapping_int_p (ctx, clause); if (decl == NULL_TREE) return NULL_TREE; + /* Handle: map(alloc:dt%cmp [len: ptr_size]) map(tofrom: D.0123...), + where GFC_DECL_SAVED_DESCRIPTOR(D.0123) is the same (here: dt%cmp). */ + if (OMP_CLAUSE_MAP_KIND (clause) == GOMP_MAP_ALLOC + || OMP_CLAUSE_MAP_KIND (clause) == GOMP_MAP_PRESENT_ALLOC) + { + tree c = clause; + while ((c = OMP_CLAUSE_CHAIN (c)) != NULL_TREE) + { + if (!gfc_omp_deep_map_kind_p (c)) + continue; + tree d = gfc_omp_deep_mapping_int_p (ctx, c); + if (d != NULL_TREE && operand_equal_p (decl, d, 0)) + return NULL_TREE; + } + } tree type = TREE_TYPE (decl); if (POINTER_TYPE_P (type)) type = TREE_TYPE (type); @@ -3044,6 +3117,15 @@ gfc_omp_deep_mapping_do (bool is_cnt, const gimple *ctx, tree clause, || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))) do_alloc_check = true; + if (!is_cnt + && (tkind == GOMP_MAP_ALLOC + || (tkind == GOMP_MAP_FROM + && (gimple_omp_target_kind (ctx) + != GF_OMP_TARGET_KIND_EXIT_DATA))) + && (poly || gfc_omp_replace_alloc_by_to_mapping (type, tmp, true))) + OMP_CLAUSE_SET_MAP_KIND (clause, tkind == GOMP_MAP_ALLOC ? GOMP_MAP_TO + : GOMP_MAP_TOFROM); + /* TODO: For map(a(:)), we know it is present & allocated. */ tree present = (DECL_P (decl) ? gfc_omp_check_optional_argument (decl, true) @@ -3071,7 +3153,7 @@ gfc_omp_deep_mapping_do (bool is_cnt, const gimple *ctx, tree clause, gfc_omp_deep_mapping_item (is_cnt, do_copy, do_alloc_check, loc, decl, &token, tkind, data, sizes, kinds, offset_data, offset, num, seq, ctx); - /* Double: Map + pointer assign. */ + /* Multiply by 2 as there are two mappings: data + pointer assign. */ if (is_cnt) gimplify_assign (num, fold_build2_loc (input_location, MULT_EXPR, diff --git a/libgomp/ChangeLog.omp b/libgomp/ChangeLog.omp index 2b0b4c71e9d..ace54f2f82f 100644 --- a/libgomp/ChangeLog.omp +++ b/libgomp/ChangeLog.omp @@ -1,3 +1,7 @@ +2023-03-23 Tobias Burnus + + * testsuite/libgomp.fortran/map-alloc-comp-8.f90: New test. + 2023-03-10 Thomas Schwinge Backported from master: diff --git a/libgomp/testsuite/libgomp.fortran/map-alloc-comp-8.f90 b/libgomp/testsuite/libgomp.fortran/map-alloc-comp-8.f90 new file mode 100644 index 00000000000..9c3c6d49daa --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/map-alloc-comp-8.f90 @@ -0,0 +1,268 @@ +module m + implicit none (type, external) + type t + integer, allocatable :: A(:) + end type t + type t2 + type(t), allocatable :: vT + integer, allocatable :: x + end type t2 + +contains + + subroutine test_alloc() + type(t) :: var + type(t), allocatable :: var2 + + allocate(var2) + allocate(var%A(4), var2%A(5)) + + !$omp target enter data map(alloc: var, var2) + !$omp target + if (.not. allocated(Var2)) stop 1 + if (.not. allocated(Var%A)) stop 2 + if (.not. allocated(Var2%A)) stop 3 + if (lbound(var%A, 1) /= 1 .or. ubound(var%A, 1) /= 4) stop 4 + if (lbound(var2%A, 1) /= 1 .or. ubound(var2%A, 1) /= 5) stop 5 + var%A = [1,2,3,4] + var2%A = [11,22,33,44,55] + !$omp end target + !$omp target exit data map(from: var, var2) + + if (.not. allocated(Var2)) error stop + if (.not. allocated(Var%A)) error stop + if (.not. allocated(Var2%A)) error stop + if (lbound(var%A, 1) /= 1 .or. ubound(var%A, 1) /= 4) error stop + if (lbound(var2%A, 1) /= 1 .or. ubound(var2%A, 1) /= 5) error stop + if (any(var%A /= [1,2,3,4])) error stop + if (any(var2%A /= [11,22,33,44,55])) error stop + end subroutine test_alloc + + subroutine test2_alloc() + type(t2) :: var + type(t2), allocatable :: var2 + + allocate(var2) + allocate(var%x, var2%x) + + !$omp target enter data map(alloc: var, var2) + !$omp target + if (.not. allocated(Var2)) stop 6 + if (.not. allocated(Var%x)) stop 7 + if (.not. allocated(Var2%x)) stop 8 + var%x = 42 + var2%x = 43 + !$omp end target + !$omp target exit data map(from: var, var2) + + if (.not. allocated(Var2)) error stop + if (.not. allocated(Var%x)) error stop + if (.not. allocated(Var2%x)) error stop + if (var%x /= 42) error stop + if (var2%x /= 43) error stop + + allocate(var%vt, var2%vt) + allocate(var%vt%A(-1:3), var2%vt%A(0:4)) + + !$omp target enter data map(alloc: var, var2) + !$omp target + if (.not. allocated(Var2)) stop 11 + if (.not. allocated(Var%x)) stop 12 + if (.not. allocated(Var2%x)) stop 13 + if (.not. allocated(Var%vt)) stop 14 + if (.not. allocated(Var2%vt)) stop 15 + if (.not. allocated(Var%vt%a)) stop 16 + if (.not. allocated(Var2%vt%a)) stop 17 + var%x = 42 + var2%x = 43 + if (lbound(var%vt%A, 1) /= -1 .or. ubound(var%vt%A, 1) /= 3) stop 4 + if (lbound(var2%vt%A, 1) /= 0 .or. ubound(var2%vt%A, 1) /= 4) stop 5 + var%vt%A = [1,2,3,4,5] + var2%vt%A = [11,22,33,44,55] + !$omp end target + !$omp target exit data map(from: var, var2) + + if (.not. allocated(Var2)) error stop + if (.not. allocated(Var%x)) error stop + if (.not. allocated(Var2%x)) error stop + if (.not. allocated(Var%vt)) error stop + if (.not. allocated(Var2%vt)) error stop + if (.not. allocated(Var%vt%a)) error stop + if (.not. allocated(Var2%vt%a)) error stop + if (var%x /= 42) error stop + if (var2%x /= 43) error stop + if (lbound(var%vt%A, 1) /= -1 .or. ubound(var%vt%A, 1) /= 3) error stop + if (lbound(var2%vt%A, 1) /= 0 .or. ubound(var2%vt%A, 1) /= 4) error stop + if (any(var%vt%A /= [1,2,3,4,5])) error stop + if (any(var2%vt%A /= [11,22,33,44,55])) error stop + end subroutine test2_alloc + + + subroutine test_alloc_target() + type(t) :: var + type(t), allocatable :: var2 + + allocate(var2) + allocate(var%A(4), var2%A(5)) + + !$omp target map(alloc: var, var2) + if (.not. allocated(Var2)) stop 1 + if (.not. allocated(Var%A)) stop 2 + if (.not. allocated(Var2%A)) stop 3 + if (lbound(var%A, 1) /= 1 .or. ubound(var%A, 1) /= 4) stop 4 + if (lbound(var2%A, 1) /= 1 .or. ubound(var2%A, 1) /= 5) stop 5 + var%A = [1,2,3,4] + var2%A = [11,22,33,44,55] + !$omp end target + + if (.not. allocated(Var2)) error stop + if (.not. allocated(Var%A)) error stop + if (.not. allocated(Var2%A)) error stop + if (lbound(var%A, 1) /= 1 .or. ubound(var%A, 1) /= 4) error stop + if (lbound(var2%A, 1) /= 1 .or. ubound(var2%A, 1) /= 5) error stop + end subroutine test_alloc_target + + subroutine test2_alloc_target() + type(t2) :: var + type(t2), allocatable :: var2 + + allocate(var2) + allocate(var%x, var2%x) + + !$omp target map(alloc: var, var2) + if (.not. allocated(Var2)) stop 6 + if (.not. allocated(Var%x)) stop 7 + if (.not. allocated(Var2%x)) stop 8 + var%x = 42 + var2%x = 43 + !$omp end target + + if (.not. allocated(Var2)) error stop + if (.not. allocated(Var%x)) error stop + if (.not. allocated(Var2%x)) error stop + + allocate(var%vt, var2%vt) + allocate(var%vt%A(-1:3), var2%vt%A(0:4)) + + !$omp target map(alloc: var, var2) + if (.not. allocated(Var2)) stop 11 + if (.not. allocated(Var%x)) stop 12 + if (.not. allocated(Var2%x)) stop 13 + if (.not. allocated(Var%vt)) stop 14 + if (.not. allocated(Var2%vt)) stop 15 + if (.not. allocated(Var%vt%a)) stop 16 + if (.not. allocated(Var2%vt%a)) stop 17 + var%x = 42 + var2%x = 43 + if (lbound(var%vt%A, 1) /= -1 .or. ubound(var%vt%A, 1) /= 3) stop 4 + if (lbound(var2%vt%A, 1) /= 0 .or. ubound(var2%vt%A, 1) /= 4) stop 5 + var%vt%A = [1,2,3,4,5] + var2%vt%A = [11,22,33,44,55] + !$omp end target + + if (.not. allocated(Var2)) error stop + if (.not. allocated(Var%x)) error stop + if (.not. allocated(Var2%x)) error stop + if (.not. allocated(Var%vt)) error stop + if (.not. allocated(Var2%vt)) error stop + if (.not. allocated(Var%vt%a)) error stop + if (.not. allocated(Var2%vt%a)) error stop + if (lbound(var%vt%A, 1) /= -1 .or. ubound(var%vt%A, 1) /= 3) error stop + if (lbound(var2%vt%A, 1) /= 0 .or. ubound(var2%vt%A, 1) /= 4) error stop + end subroutine test2_alloc_target + + + + subroutine test_from() + type(t) :: var + type(t), allocatable :: var2 + + allocate(var2) + allocate(var%A(4), var2%A(5)) + + !$omp target map(from: var, var2) + if (.not. allocated(Var2)) stop 1 + if (.not. allocated(Var%A)) stop 2 + if (.not. allocated(Var2%A)) stop 3 + if (lbound(var%A, 1) /= 1 .or. ubound(var%A, 1) /= 4) stop 4 + if (lbound(var2%A, 1) /= 1 .or. ubound(var2%A, 1) /= 5) stop 5 + var%A = [1,2,3,4] + var2%A = [11,22,33,44,55] + !$omp end target + + if (.not. allocated(Var2)) error stop + if (.not. allocated(Var%A)) error stop + if (.not. allocated(Var2%A)) error stop + if (lbound(var%A, 1) /= 1 .or. ubound(var%A, 1) /= 4) error stop + if (lbound(var2%A, 1) /= 1 .or. ubound(var2%A, 1) /= 5) error stop + if (any(var%A /= [1,2,3,4])) error stop + if (any(var2%A /= [11,22,33,44,55])) error stop + end subroutine test_from + + subroutine test2_from() + type(t2) :: var + type(t2), allocatable :: var2 + + allocate(var2) + allocate(var%x, var2%x) + + !$omp target map(from: var, var2) + if (.not. allocated(Var2)) stop 6 + if (.not. allocated(Var%x)) stop 7 + if (.not. allocated(Var2%x)) stop 8 + var%x = 42 + var2%x = 43 + !$omp end target + + if (.not. allocated(Var2)) error stop + if (.not. allocated(Var%x)) error stop + if (.not. allocated(Var2%x)) error stop + if (var%x /= 42) error stop + if (var2%x /= 43) error stop + + allocate(var%vt, var2%vt) + allocate(var%vt%A(-1:3), var2%vt%A(0:4)) + + !$omp target map(from: var, var2) + if (.not. allocated(Var2)) stop 11 + if (.not. allocated(Var%x)) stop 12 + if (.not. allocated(Var2%x)) stop 13 + if (.not. allocated(Var%vt)) stop 14 + if (.not. allocated(Var2%vt)) stop 15 + if (.not. allocated(Var%vt%a)) stop 16 + if (.not. allocated(Var2%vt%a)) stop 17 + var%x = 42 + var2%x = 43 + if (lbound(var%vt%A, 1) /= -1 .or. ubound(var%vt%A, 1) /= 3) stop 4 + if (lbound(var2%vt%A, 1) /= 0 .or. ubound(var2%vt%A, 1) /= 4) stop 5 + var%vt%A = [1,2,3,4,5] + var2%vt%A = [11,22,33,44,55] + !$omp end target + + if (.not. allocated(Var2)) error stop + if (.not. allocated(Var%x)) error stop + if (.not. allocated(Var2%x)) error stop + if (.not. allocated(Var%vt)) error stop + if (.not. allocated(Var2%vt)) error stop + if (.not. allocated(Var%vt%a)) error stop + if (.not. allocated(Var2%vt%a)) error stop + if (var%x /= 42) error stop + if (var2%x /= 43) error stop + if (lbound(var%vt%A, 1) /= -1 .or. ubound(var%vt%A, 1) /= 3) error stop + if (lbound(var2%vt%A, 1) /= 0 .or. ubound(var2%vt%A, 1) /= 4) error stop + if (any(var%vt%A /= [1,2,3,4,5])) error stop + if (any(var2%vt%A /= [11,22,33,44,55])) error stop + end subroutine test2_from + +end module m + +use m + implicit none (type, external) + call test_alloc + call test2_alloc + call test_alloc_target + call test2_alloc_target + + call test_from + call test2_from +end