From patchwork Wed Nov 20 13:06:18 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 1198126 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-514146-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="g0EBD+Su"; dkim-atps=neutral Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 47J2ym1Pndz9sPV for ; Thu, 21 Nov 2019 00:06:54 +1100 (AEDT) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:from :subject:to:message-id:date:mime-version:content-type; q=dns; s= default; b=WlPkLwSvgIT0gU8Bmf5XF10XiOf52Qiyl2pXfnAA3wrFNTGwMJ88b pHRBXM7QgiZcoGRqoYSCYj17hHZb1pE0sbATJrdR3RGo7FXCUd/pZ1JsMm6IDgln POfjWIHo+SDFdwokXi+nlA47C7BnD3HUKpB+wU2oZ7/RJFOxSHg2Ik= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:from :subject:to:message-id:date:mime-version:content-type; s= default; bh=U8hO64pXTA9HzY8JXnNeCjnivUI=; b=g0EBD+SuDeXQLxVXbeif fGayOcXj3BSwOYb3/FW8G2fjVXuwIG+liIMs4IMnuCKE6afol6kOCdWB7T57tqey t/+190qC1CZbVDYoDQ46Ox8T+X0SsCAP6SiDQPkpDxlYsSmlxepfD2jN9+fNQU+o zAP7PbyYiQlUa+N0Lwip/ac= Received: (qmail 59575 invoked by alias); 20 Nov 2019 13:06:42 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 59560 invoked by uid 89); 20 Nov 2019 13:06:42 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-21.4 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_0, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, KAM_SHORT, SPF_PASS autolearn=ham version=3.3.1 spammy=Cheung, gang, kcy@codesourcery.com, Kwok 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; Wed, 20 Nov 2019 13:06:32 +0000 IronPort-SDR: +YJhqqlM9eZxhxXen2PUbp3FhQkhzUml/9J+pDXmOSe8G7pqPOVdVUblSS0aGZVprCtj4mTfgA so7MWwzZM7MEp0tRKP0mmGiV7oZZPxZuBINlAm1tgDoaDbxJGVubkDEm8oL/nHfC1ZTmaNNPvl Wz2EbDjd/YnHizWi2oiGYCneo4afAdbtNKoEURRWRV7eEF62DN+H6Rzib9QKiOTIX8fYYwcZGF MDvrCosBEQPPvz3gVfTLzdYzxOCgRXay2X2M2gbT2AhvzmhffC3mYSCOOuE6KYWFLpvfdRDLH2 8Fw= Received: from orw-gwy-01-in.mentorg.com ([192.94.38.165]) by esa1.mentor.iphmx.com with ESMTP; 20 Nov 2019 05:06:30 -0800 IronPort-SDR: HbVZQAjmz0Fk1WWCp3FQwaV1euGDXCLixnvkOcqs/Cl/fJ1LV+RCkmODsyj7Znl0I+UZ/EMoO7 WGUYU5mlYJz5Q1OmAcj9ZjALrgnVrL2ehXBX+Iq4f/UZwuabvj9Nk0euzErTTOB/aHhLzi5NiW 3e1CpiZfWZruKYtTGInx6eKhtgphb3It3R1hxNWqm2fg2p1z+xne7vgTvrUGtHZBUB8hF6luPQ A56IN1OJi5RxKwSmWNmvPI2rbs35r6tiFnvxvw45wERXJnwQAPhkyZcUYsuLxtgSIkXXtu2HcW veo= From: Tobias Burnus Subject: [Patch][OpenMP/OpenACC/Fortran] Fix mapping of optional (present|absent) arguments To: gcc-patches , fortran , Jakub Jelinek , Thomas Schwinge Message-ID: <8be82276-81b1-817c-fcd2-51f24f5fe2d2@codesourcery.com> Date: Wed, 20 Nov 2019 14:06:18 +0100 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:68.0) Gecko/20100101 Thunderbird/68.2.1 MIME-Version: 1.0 X-IsSubscribed: yes This patch does two things regarding explicit and automatical variable mapping to offloaded devices: * Fixes bugs with optional arguments, which are present. They were mapped but the mapping had issues causing run-time failures. * It now also handles absent optional arguments. Compared to the previous patch set,** I added several OpenMP test cases – and fixed the fallout. Except for trivial changes to libgomp/oacc-mem.c and omp-low.c, all changes are in fortran/trans-openmp.c and only affect optional arguments. The patch was bootstrapped and tested on x86_64-gnu-linux w/o offloading-support configured and with nvptx offloading. Tobias ** Included in the attached patch are the following previously posted patches: [1] the trivial libgomp/oacc-mem.c change, [2] only the remaining single-line change in omp-low.c, [3] the trans-openmp.c changes (which had to be modified+extended), and [5] the test cases. ([2] and [4] are already in GCC 10.) See: https://gcc.gnu.org/ml/gcc-patches/2019-07/threads.html#00960 for the original patches. PS: For full OpenMP support, (absent) optional arguments also needed to be handled for data-share clauses. 2019-10-20 Tobias Burnus Kwok Cheung Yeung gcc/fortran/ * trans-openmp.c (gfc_build_conditional_assign, gfc_build_conditional_assign_expr): New static functions. (gfc_omp_finish_clause, gfc_trans_omp_clauses): Handle mapping of absent optional arguments and fix mapping of present optional args. gcc/ * omp-low.c (lower_omp_target): For optional arguments, deref once more to obtain the type. libgomp/ * oacc-mem.c (update_dev_host, gomp_acc_insert_pointer): Just return if input it a NULL pointer. * testsuite/libgomp.oacc-c-c++-common/lib-43.c: Remove; dependent on diagnostic of NULL pointer. * testsuite/libgomp.oacc-c-c++-common/lib-47.c: Ditto. * testsuite/libgomp.fortran/optional-map.f90: New. * testsuite/libgomp.fortran/use_device_addr-1.f90 (test_dummy_opt_callee_1_absent): New. (test_dummy_opt_call_1): Call it. * testsuite/libgomp.fortran/use_device_addr-2.f90: Likewise. * testsuite/libgomp.fortran/use_device_addr-3.f90: Likewise. * testsuite/libgomp.fortran/use_device_addr-4.f90: Likewise. * testsuite/libgomp.oacc-fortran/optional-cache.f95: New. * testsuite/libgomp.oacc-fortran/optional-data-copyin-by-value.f90: New. * testsuite/libgomp.oacc-fortran/optional-data-copyin.f90: New. * testsuite/libgomp.oacc-fortran/optional-data-copyout.f90: New. * testsuite/libgomp.oacc-fortran/optional-data-enter-exit.f90: New. * testsuite/libgomp.oacc-fortran/optional-declare.f90: New. * testsuite/libgomp.oacc-fortran/optional-firstprivate.f90: New. * testsuite/libgomp.oacc-fortran/optional-host_data.f90: New. * testsuite/libgomp.oacc-fortran/optional-nested-calls.f90: New. * testsuite/libgomp.oacc-fortran/optional-private.f90: New. * testsuite/libgomp.oacc-fortran/optional-reduction.f90: New. * testsuite/libgomp.oacc-fortran/optional-update-device.f90: New. * testsuite/libgomp.oacc-fortran/optional-update-host.f90: New. gcc/fortran/trans-openmp.c | 224 ++++++++++++++++++++++++++++++++++++--- gcc/omp-low.c | 3 +- libgomp/oacc-mem.c | 9 ++ libgomp/testsuite/libgomp.fortran/optional-map.f90 | 119 +++++++++++++++++++++ libgomp/testsuite/libgomp.fortran/use_device_addr-1.f90 | 36 +++++++ libgomp/testsuite/libgomp.fortran/use_device_addr-2.f90 | 36 +++++++ libgomp/testsuite/libgomp.fortran/use_device_addr-3.f90 | 27 +++++ libgomp/testsuite/libgomp.fortran/use_device_addr-4.f90 | 27 +++++ libgomp/testsuite/libgomp.oacc-c-c++-common/lib-43.c | 51 --------- libgomp/testsuite/libgomp.oacc-c-c++-common/lib-47.c | 49 --------- libgomp/testsuite/libgomp.oacc-fortran/optional-cache.f95 | 23 ++++ libgomp/testsuite/libgomp.oacc-fortran/optional-data-copyin-by-value.f90 | 29 +++++ libgomp/testsuite/libgomp.oacc-fortran/optional-data-copyin.f90 | 140 ++++++++++++++++++++++++ libgomp/testsuite/libgomp.oacc-fortran/optional-data-copyout.f90 | 96 +++++++++++++++++ libgomp/testsuite/libgomp.oacc-fortran/optional-data-enter-exit.f90 | 91 ++++++++++++++++ libgomp/testsuite/libgomp.oacc-fortran/optional-declare.f90 | 87 +++++++++++++++ libgomp/testsuite/libgomp.oacc-fortran/optional-firstprivate.f90 | 112 ++++++++++++++++++++ libgomp/testsuite/libgomp.oacc-fortran/optional-host_data.f90 | 39 +++++++ libgomp/testsuite/libgomp.oacc-fortran/optional-nested-calls.f90 | 135 +++++++++++++++++++++++ libgomp/testsuite/libgomp.oacc-fortran/optional-private.f90 | 115 ++++++++++++++++++++ libgomp/testsuite/libgomp.oacc-fortran/optional-reduction.f90 | 69 ++++++++++++ libgomp/testsuite/libgomp.oacc-fortran/optional-update-device.f90 | 121 +++++++++++++++++++++ libgomp/testsuite/libgomp.oacc-fortran/optional-update-host.f90 | 115 ++++++++++++++++++++ 23 files changed, 1640 insertions(+), 113 deletions(-) diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index d9dfcabc65e..77bc9120d85 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -1175,6 +1175,64 @@ gfc_omp_clause_dtor (tree clause, tree decl) return tem; } +/* Build a conditional expression in BLOCK. If COND_VAL is not + null, then the block THEN_B is executed, otherwise ELSE_VAL + is assigned to VAL. */ + +static void +gfc_build_conditional_assign (stmtblock_t *block, + tree val, + tree cond_val, + tree then_b, + tree else_val) +{ + stmtblock_t cond_block; + tree cond, else_b = NULL_TREE; + tree val_ty = TREE_TYPE (val); + + if (else_val) + { + gfc_init_block (&cond_block); + gfc_add_modify (&cond_block, val, fold_convert (val_ty, else_val)); + else_b = gfc_finish_block (&cond_block); + } + cond = fold_build2_loc (input_location, NE_EXPR, + logical_type_node, + cond_val, null_pointer_node); + gfc_add_expr_to_block (block, + build3_loc (input_location, + COND_EXPR, + void_type_node, + cond, then_b, + else_b)); +} + +/* Build a conditional expression in BLOCK, returning a temporary + variable containing the result. If COND_VAL is not null, then + THEN_VAL will be assigned to the variable, otherwise ELSE_VAL + is assigned. + */ + +static tree +gfc_build_conditional_assign_expr (stmtblock_t *block, + tree cond_val, + tree then_val, + tree else_val) +{ + tree val; + tree val_ty = TREE_TYPE (then_val); + stmtblock_t cond_block; + + val = create_tmp_var (val_ty); + + gfc_init_block (&cond_block); + gfc_add_modify (&cond_block, val, then_val); + tree then_b = gfc_finish_block (&cond_block); + + gfc_build_conditional_assign (block, val, cond_val, then_b, else_val); + + return val; +} void gfc_omp_finish_clause (tree c, gimple_seq *pre_p) @@ -1199,6 +1257,8 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p) } tree c2 = NULL_TREE, c3 = NULL_TREE, c4 = NULL_TREE; + tree present = gfc_omp_is_optional_argument (decl) + ? gfc_omp_check_optional_argument (decl, true) : NULL_TREE; if (POINTER_TYPE_P (TREE_TYPE (decl))) { if (!gfc_omp_privatize_by_reference (decl) @@ -1213,8 +1273,30 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p) OMP_CLAUSE_DECL (c4) = decl; OMP_CLAUSE_SIZE (c4) = size_int (0); decl = build_fold_indirect_ref (decl); - OMP_CLAUSE_DECL (c) = decl; - OMP_CLAUSE_SIZE (c) = NULL_TREE; + if (present + && (GFC_DECL_GET_SCALAR_POINTER (orig_decl) + || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl))) + { + c2 = build_omp_clause (input_location, OMP_CLAUSE_MAP); + OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_POINTER); + OMP_CLAUSE_DECL (c2) = decl; + OMP_CLAUSE_SIZE (c2) = size_int (0); + + stmtblock_t block; + gfc_start_block (&block); + tree ptr = decl; + ptr = gfc_build_conditional_assign_expr (&block, present, decl, + null_pointer_node); + gimplify_and_add (gfc_finish_block (&block), pre_p); + ptr = build_fold_indirect_ref (ptr); + OMP_CLAUSE_DECL (c) = ptr; + OMP_CLAUSE_SIZE (c) = TYPE_SIZE_UNIT (TREE_TYPE (ptr)); + } + else + { + OMP_CLAUSE_DECL (c) = decl; + OMP_CLAUSE_SIZE (c) = NULL_TREE; + } if (TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE && (GFC_DECL_GET_SCALAR_POINTER (orig_decl) || GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl))) @@ -1232,17 +1314,43 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p) stmtblock_t block; gfc_start_block (&block); tree type = TREE_TYPE (decl); - tree ptr = gfc_conv_descriptor_data_get (decl); + tree ptr; + + if (present) + ptr = gfc_build_conditional_assign_expr ( + &block, present, + gfc_conv_descriptor_data_get (decl), + null_pointer_node); + else + ptr = gfc_conv_descriptor_data_get (decl); ptr = fold_convert (build_pointer_type (char_type_node), ptr); ptr = build_fold_indirect_ref (ptr); OMP_CLAUSE_DECL (c) = ptr; c2 = build_omp_clause (input_location, OMP_CLAUSE_MAP); OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_TO_PSET); - OMP_CLAUSE_DECL (c2) = decl; + if (present) + { + ptr = create_tmp_var (TREE_TYPE (TREE_OPERAND (decl, 0))); + gfc_add_modify (&block, ptr, TREE_OPERAND (decl, 0)); + + OMP_CLAUSE_DECL (c2) = build_fold_indirect_ref (ptr); + } + else + OMP_CLAUSE_DECL (c2) = decl; OMP_CLAUSE_SIZE (c2) = TYPE_SIZE_UNIT (type); c3 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP); OMP_CLAUSE_SET_MAP_KIND (c3, GOMP_MAP_POINTER); - OMP_CLAUSE_DECL (c3) = gfc_conv_descriptor_data_get (decl); + if (present) + { + ptr = gfc_conv_descriptor_data_get (decl); + ptr = gfc_build_addr_expr (NULL, ptr); + ptr = gfc_build_conditional_assign_expr (&block, present, + ptr, null_pointer_node); + ptr = build_fold_indirect_ref (ptr); + OMP_CLAUSE_DECL (c3) = ptr; + } + else + OMP_CLAUSE_DECL (c3) = gfc_conv_descriptor_data_get (decl); OMP_CLAUSE_SIZE (c3) = size_int (0); tree size = create_tmp_var (gfc_array_index_type); tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type)); @@ -1268,11 +1376,36 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p) tem = gfc_conv_descriptor_data_get (decl); tem = fold_convert (pvoid_type_node, tem); cond = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, tem, null_pointer_node); + boolean_type_node, tem, null_pointer_node); + if (present) + { + tem = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + present, null_pointer_node); + cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, tem, cond); + } gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, void_type_node, cond, then_b, else_b)); } + else if (present) + { + stmtblock_t cond_block; + tree then_b; + + gfc_init_block (&cond_block); + gfc_add_modify (&cond_block, size, + gfc_full_array_size (&cond_block, decl, + GFC_TYPE_ARRAY_RANK (type))); + gfc_add_modify (&cond_block, size, + fold_build2 (MULT_EXPR, gfc_array_index_type, + size, elemsz)); + then_b = gfc_finish_block (&cond_block); + + gfc_build_conditional_assign (&block, size, present, then_b, + build_int_cst (gfc_array_index_type, + 0)); + } else { gfc_add_modify (&block, size, @@ -2252,6 +2385,9 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, TREE_ADDRESSABLE (decl) = 1; if (n->expr == NULL || n->expr->ref->u.ar.type == AR_FULL) { + tree present = gfc_omp_is_optional_argument (decl) + ? gfc_omp_check_optional_argument (decl, true) + : NULL_TREE; if (POINTER_TYPE_P (TREE_TYPE (decl)) && (gfc_omp_privatize_by_reference (decl) || GFC_DECL_GET_SCALAR_POINTER (decl) @@ -2284,6 +2420,10 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, { tree type = TREE_TYPE (decl); tree ptr = gfc_conv_descriptor_data_get (decl); + if (present) + ptr = gfc_build_conditional_assign_expr ( + block, present, ptr, + null_pointer_node); ptr = fold_convert (build_pointer_type (char_type_node), ptr); ptr = build_fold_indirect_ref (ptr); @@ -2296,8 +2436,19 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, node3 = build_omp_clause (input_location, OMP_CLAUSE_MAP); OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER); - OMP_CLAUSE_DECL (node3) - = gfc_conv_descriptor_data_get (decl); + if (present) + { + ptr = gfc_conv_descriptor_data_get (decl); + ptr = gfc_build_addr_expr (NULL, ptr); + ptr = gfc_build_conditional_assign_expr ( + block, present, ptr, + null_pointer_node); + ptr = build_fold_indirect_ref (ptr); + OMP_CLAUSE_DECL (node3) = ptr; + } + else + OMP_CLAUSE_DECL (node3) + = gfc_conv_descriptor_data_get (decl); OMP_CLAUSE_SIZE (node3) = size_int (0); /* We have to check for n->sym->attr.dimension because @@ -2322,8 +2473,20 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, tem = gfc_conv_descriptor_data_get (decl); tem = fold_convert (pvoid_type_node, tem); cond = fold_build2_loc (input_location, NE_EXPR, - logical_type_node, + boolean_type_node, tem, null_pointer_node); + if (present) + { + tree tmp = fold_build2_loc (input_location, + NE_EXPR, + boolean_type_node, + present, + null_pointer_node); + cond = fold_build2_loc (input_location, + TRUTH_ANDIF_EXPR, + boolean_type_node, + tmp, cond); + } gfc_add_expr_to_block (block, build3_loc (input_location, COND_EXPR, @@ -2333,9 +2496,34 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, OMP_CLAUSE_SIZE (node) = size; } else if (n->sym->attr.dimension) - OMP_CLAUSE_SIZE (node) - = gfc_full_array_size (block, decl, - GFC_TYPE_ARRAY_RANK (type)); + { + stmtblock_t cond_block; + gfc_init_block (&cond_block); + tree size = gfc_full_array_size (&cond_block, decl, + GFC_TYPE_ARRAY_RANK (type)); + if (present) + { + tree var = gfc_create_var (gfc_array_index_type, + NULL); + tree cond = fold_build2_loc (input_location, + NE_EXPR, + boolean_type_node, + present, + null_pointer_node); + gfc_add_modify (&cond_block, var, size); + gfc_add_expr_to_block (block, + build3_loc (input_location, COND_EXPR, + void_type_node, cond, + gfc_finish_block (&cond_block), + NULL_TREE)); + OMP_CLAUSE_SIZE (node) = var; + } + else + { + gfc_add_block_to_block (block, &cond_block); + OMP_CLAUSE_SIZE (node) = size; + } + } if (n->sym->attr.dimension) { tree elemsz @@ -2346,6 +2534,18 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, OMP_CLAUSE_SIZE (node), elemsz); } } + else if (present + && TREE_CODE (decl) == INDIRECT_REF + && TREE_CODE (TREE_OPERAND (decl, 0)) + == INDIRECT_REF) + { + /* A single indirectref is handled by the middle end. */ + gcc_assert (!POINTER_TYPE_P (TREE_TYPE (decl))); + decl = TREE_OPERAND (decl, 0); + decl = gfc_build_conditional_assign_expr ( + block, present, decl, null_pointer_node); + OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (decl); + } else OMP_CLAUSE_DECL (node) = decl; } diff --git a/gcc/omp-low.c b/gcc/omp-low.c index 19132f76da2..8d6742e7223 100644 --- a/gcc/omp-low.c +++ b/gcc/omp-low.c @@ -11817,7 +11817,8 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx) { gcc_checking_assert (is_gimple_omp_oacc (ctx->stmt)); s = TREE_TYPE (ovar); - if (TREE_CODE (s) == REFERENCE_TYPE) + if (TREE_CODE (s) == REFERENCE_TYPE + || omp_check_optional_argument (ovar, false)) s = TREE_TYPE (s); s = TYPE_SIZE_UNIT (s); } diff --git a/libgomp/oacc-mem.c b/libgomp/oacc-mem.c index 2f271009fb8..e5088014ccc 100644 --- a/libgomp/oacc-mem.c +++ b/libgomp/oacc-mem.c @@ -831,6 +831,12 @@ update_dev_host (int is_dev, void *h, size_t s, int async) if (acc_dev->capabilities & GOMP_OFFLOAD_CAP_SHARED_MEM) return; + /* Fortran optional arguments that are non-present result in a + NULL host address here. This can safely be ignored as it is + not possible to 'update' a non-present optional argument. */ + if (h == NULL) + return; + acc_prof_info prof_info; acc_api_info api_info; bool profiling_p = GOACC_PROFILING_SETUP_P (thr, &prof_info, &api_info); @@ -901,6 +907,9 @@ gomp_acc_insert_pointer (size_t mapnum, void **hostaddrs, size_t *sizes, struct goacc_thread *thr = goacc_thread (); struct gomp_device_descr *acc_dev = thr->dev; + if (*hostaddrs == NULL) + return; + if (acc_is_present (*hostaddrs, *sizes)) { splay_tree_key n; diff --git a/libgomp/testsuite/libgomp.fortran/optional-map.f90 b/libgomp/testsuite/libgomp.fortran/optional-map.f90 new file mode 100644 index 00000000000..56f6e59e815 --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/optional-map.f90 @@ -0,0 +1,119 @@ +implicit none (type, external) +call sub() +call sub2() +call call_present_1() +call call_present_2() + +contains + +subroutine call_present_1() + integer :: ii, ival, iarr, iptr, iparr + pointer :: iptr, iparr + dimension :: iarr(2), iparr(:) + allocate(iptr,iparr(2)) + ii = 101 + ival = 102 + iptr = 103 + iarr = 104 + iparr = 105 + call sub_present(ii, ival, iarr, iptr, iparr) + deallocate(iptr,iparr) +end subroutine + +subroutine call_present_2() + integer :: ii, ival, iarr, iptr, iparr + pointer :: iptr, iparr + dimension :: iarr(2), iparr(:) + allocate(iptr,iparr(2)) + ii = 201 + ival = 202 + iptr = 203 + iarr = 204 + iparr = 205 + call sub2_present(ii, ival, iarr, iptr, iparr) + deallocate(iptr,iparr) +end subroutine + +subroutine sub(ii, ival, iarr, iptr, iparr) + integer, optional :: ii, ival, iarr, iptr, iparr + pointer :: iptr, iparr + dimension :: iarr(:), iparr(:) + value :: ival + integer :: err + err = 42 + !$omp target map(ii, ival, iarr, iptr, iparr, err) + if (present(ii)) then + ii = iptr + ival + iarr = iparr + else + err = 0 + end if + if (present(ii)) err = 1 + if (present(ival)) err = 2 + if (present(iarr)) err = 3 + if (present(iptr)) err = 4 + if (present(iparr)) err = 5 + !$omp end target + if (err /= 0) stop 1 +end subroutine sub + +subroutine sub2(ii, ival, iarr, iptr, iparr) + integer, optional :: ii, ival, iarr, iptr, iparr + pointer :: iptr, iparr + dimension :: iarr(:), iparr(:) + value :: ival + integer :: err(1) ! otherwise, implied defaultmap is firstprivate + err(1) = 42 + !$omp target ! automatic mapping with implied defaultmap(tofrom) + if (present(ii)) then + ii = iptr + ival + iarr = iparr + else + err(1) = 0 + end if + if (present(ii)) err(1) = 1 + if (present(ival)) err(1) = 2 + if (present(iarr)) err(1) = 3 + if (present(iptr)) err(1) = 4 + if (present(iparr)) err(1) = 5 + !$omp end target + if (err(1) /= 0) stop 2 +end subroutine sub2 + +subroutine sub_present(ii, ival, iarr, iptr, iparr) + integer, optional :: ii, ival, iarr, iptr, iparr + pointer :: iptr, iparr + dimension :: iarr(:), iparr(:) + value :: ival + integer :: err + err = 42 + !$omp target map(ii, ival, iarr, iptr, iparr, err) + if (.not.present(ii)) err = 1 + if (.not.present(ival)) err = 2 + if (.not.present(iarr)) err = 3 + if (.not.present(iptr)) err = 4 + if (.not.present(iparr)) err = 5 + err = err - 42 - 101-102-103-104-105 + ii+ival+iarr(2)+iptr+iparr(2) + !$omp end target + if (err /= 0) stop 3 +end subroutine sub_present + +subroutine sub2_present(ii, ival, iarr, iptr, iparr) + integer, optional :: ii, ival, iarr, iptr, iparr + pointer :: iptr, iparr + dimension :: iarr(:), iparr(:) + value :: ival + integer :: err(1) ! otherwise, implied defaultmap is firstprivate + err(1) = 53 + !$omp target ! automatic mapping with implied defaultmap(tofrom) + ! Note: OpenMP 4.5's 'defaultmap' is not yet supported, PR 92568 + if (.not.present(ii)) err = 1 + if (.not.present(ival)) err = 2 + if (.not.present(iarr)) err = 3 + if (.not.present(iptr)) err = 4 + if (.not.present(iparr)) err = 5 + err = err - 53 - 201-202-203-204-205 + ii+ival+iarr(2)+iptr+iparr(2) + !$omp end target + if (err(1) /= 0) stop 4 +end subroutine sub2_present +end diff --git a/libgomp/testsuite/libgomp.fortran/use_device_addr-1.f90 b/libgomp/testsuite/libgomp.fortran/use_device_addr-1.f90 index 94ac76f5700..0254f2dc196 100644 --- a/libgomp/testsuite/libgomp.fortran/use_device_addr-1.f90 +++ b/libgomp/testsuite/libgomp.fortran/use_device_addr-1.f90 @@ -472,6 +472,7 @@ contains hh = 88.0_c_double call test_dummy_opt_callee_1(aa, bb, cc, dd, ee, ff, gg, hh, N) + call test_dummy_opt_callee_1_absent(N=N) deallocate(ee, ff) ! pointers, only end subroutine test_dummy_opt_call_1 @@ -527,6 +528,41 @@ contains if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) stop 72 end subroutine test_dummy_opt_callee_1 + subroutine test_dummy_opt_callee_1_absent(aa, bb, cc, dd, ee, ff, gg, hh, N) + ! scalars + real(c_double), optional, target :: aa, bb + real(c_double), optional, target, allocatable :: cc, dd + real(c_double), optional, pointer :: ee, ff + + ! non-descriptor arrays + real(c_double), optional, target :: gg(N), hh(N) + integer, value :: N + + integer :: err + + ! All shall be absent + if (present(aa) .or. present(bb)) stop 243 + if (present(cc) .or. present(dd)) stop 244 + if (present(ee) .or. present(ff)) stop 245 + if (present(gg) .or. present(hh)) stop 246 + + !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb) + if (present(aa) .or. present(bb)) stop 247 + !$omp end target data + + !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd) + if (present(cc) .or. present(dd)) stop 248 + !$omp end target data + + !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff) + if (present(ee) .or. present(ff)) stop 249 + !$omp end target data + + !$omp target data map(to:gg) map(from:hh) use_device_addr(gg,hh) + if (present(gg) .or. present(hh)) stop 250 + !$omp end target data + end subroutine test_dummy_opt_callee_1_absent + ! Save device ptr - and recall pointer subroutine test_dummy_opt_call_2() integer, parameter :: N = 1000 diff --git a/libgomp/testsuite/libgomp.fortran/use_device_addr-2.f90 b/libgomp/testsuite/libgomp.fortran/use_device_addr-2.f90 index d6c5a672370..3dd1f90f04c 100644 --- a/libgomp/testsuite/libgomp.fortran/use_device_addr-2.f90 +++ b/libgomp/testsuite/libgomp.fortran/use_device_addr-2.f90 @@ -472,6 +472,7 @@ contains hh = 88.0_c_float call test_dummy_opt_callee_1(aa, bb, cc, dd, ee, ff, gg, hh, N) + call test_dummy_opt_callee_1_absent(N=N) deallocate(ee, ff) ! pointers, only end subroutine test_dummy_opt_call_1 @@ -527,6 +528,41 @@ contains if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) stop 72 end subroutine test_dummy_opt_callee_1 + subroutine test_dummy_opt_callee_1_absent(aa, bb, cc, dd, ee, ff, gg, hh, N) + ! scalars + real(c_float), optional, target :: aa, bb + real(c_float), optional, target, allocatable :: cc, dd + real(c_float), optional, pointer :: ee, ff + + ! non-descriptor arrays + real(c_float), optional, target :: gg(N), hh(N) + integer, value :: N + + integer :: err + + ! All shall be absent + if (present(aa) .or. present(bb)) stop 243 + if (present(cc) .or. present(dd)) stop 244 + if (present(ee) .or. present(ff)) stop 245 + if (present(gg) .or. present(hh)) stop 246 + + !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb) + if (present(aa) .or. present(bb)) stop 247 + !$omp end target data + + !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd) + if (present(cc) .or. present(dd)) stop 248 + !$omp end target data + + !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff) + if (present(ee) .or. present(ff)) stop 249 + !$omp end target data + + !$omp target data map(to:gg) map(from:hh) use_device_addr(gg,hh) + if (present(gg) .or. present(hh)) stop 250 + !$omp end target data + end subroutine test_dummy_opt_callee_1_absent + ! Save device ptr - and recall pointer subroutine test_dummy_opt_call_2() integer, parameter :: N = 1000 diff --git a/libgomp/testsuite/libgomp.fortran/use_device_addr-3.f90 b/libgomp/testsuite/libgomp.fortran/use_device_addr-3.f90 index 5c42bee718c..82cf9ac8070 100644 --- a/libgomp/testsuite/libgomp.fortran/use_device_addr-3.f90 +++ b/libgomp/testsuite/libgomp.fortran/use_device_addr-3.f90 @@ -290,6 +290,7 @@ contains ff = 66.0_c_double call test_dummy_opt_callee_1(aa, bb, cc, dd, ee, ff, N) + call test_dummy_opt_callee_1_absent(N=N) deallocate(ee, ff) ! pointers, only end subroutine test_dummy_opt_call_1 @@ -336,6 +337,32 @@ contains if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 1 end subroutine test_dummy_opt_callee_1 + subroutine test_dummy_opt_callee_1_absent(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 absent + if (present(aa) .or. present(bb)) stop 1 + if (present(cc) .or. present(dd)) stop 1 + if (present(ee) .or. present(ff)) stop 1 + + !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb) + if (present(aa) .or. present(bb)) stop 1 + !$omp end target data + + !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd) + if (present(cc) .or. present(dd)) stop 1 + !$omp end target data + + !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff) + if (present(ee) .or. present(ff)) stop 1 + !$omp end target data + end subroutine test_dummy_opt_callee_1_absent + ! Save device ptr - and recall pointer subroutine test_dummy_opt_call_2() integer, parameter :: N = 1000 diff --git a/libgomp/testsuite/libgomp.fortran/use_device_addr-4.f90 b/libgomp/testsuite/libgomp.fortran/use_device_addr-4.f90 index 5e66a79da90..d17249de2bc 100644 --- a/libgomp/testsuite/libgomp.fortran/use_device_addr-4.f90 +++ b/libgomp/testsuite/libgomp.fortran/use_device_addr-4.f90 @@ -290,6 +290,7 @@ contains ff = 66.0_c_float call test_dummy_opt_callee_1(aa, bb, cc, dd, ee, ff, N) + call test_dummy_opt_callee_1_absent(N=N) deallocate(ee, ff) ! pointers, only end subroutine test_dummy_opt_call_1 @@ -336,6 +337,32 @@ contains if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 1 end subroutine test_dummy_opt_callee_1 + subroutine test_dummy_opt_callee_1_absent(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 absent + if (present(aa) .or. present(bb)) stop 1 + if (present(cc) .or. present(dd)) stop 1 + if (present(ee) .or. present(ff)) stop 1 + + !$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb) + if (present(aa) .or. present(bb)) stop 1 + !$omp end target data + + !$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd) + if (present(cc) .or. present(dd)) stop 1 + !$omp end target data + + !$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff) + if (present(ee) .or. present(ff)) stop 1 + !$omp end target data + end subroutine test_dummy_opt_callee_1_absent + ! Save device ptr - and recall pointer subroutine test_dummy_opt_call_2() integer, parameter :: N = 1000 diff --git a/libgomp/testsuite/libgomp.oacc-c-c++-common/lib-43.c b/libgomp/testsuite/libgomp.oacc-c-c++-common/lib-43.c deleted file mode 100644 index 5db29124e9e..00000000000 --- a/libgomp/testsuite/libgomp.oacc-c-c++-common/lib-43.c +++ /dev/null @@ -1,51 +0,0 @@ -/* Exercise acc_update_device with a NULL data address on nvidia targets. */ - -/* { dg-do run { target openacc_nvidia_accel_selected } } */ - -#include -#include -#include - -int -main (int argc, char **argv) -{ - const int N = 256; - int i; - unsigned char *h; - void *d; - - h = (unsigned char *) malloc (N); - - for (i = 0; i < N; i++) - { - h[i] = i; - } - - d = acc_copyin (h, N); - if (!d) - abort (); - - for (i = 0; i < N; i++) - { - h[i] = 0xab; - } - - fprintf (stderr, "CheCKpOInT\n"); - acc_update_device (0, N); - - acc_copyout (h, N); - - for (i = 0; i < N; i++) - { - if (h[i] != 0xab) - abort (); - } - - free (h); - - return 0; -} - -/* { dg-output "CheCKpOInT(\n|\r\n|\r).*" } */ -/* { dg-output "\\\[\[^\n\r]*,256\\\] is not mapped" } */ -/* { dg-shouldfail "" } */ diff --git a/libgomp/testsuite/libgomp.oacc-c-c++-common/lib-47.c b/libgomp/testsuite/libgomp.oacc-c-c++-common/lib-47.c deleted file mode 100644 index c2140429cb1..00000000000 --- a/libgomp/testsuite/libgomp.oacc-c-c++-common/lib-47.c +++ /dev/null @@ -1,49 +0,0 @@ -/* Exercise acc_update_self with a NULL data mapping on nvidia targets. */ - -/* { dg-do run { target openacc_nvidia_accel_selected } } */ - -#include -#include -#include -#include - -int -main (int argc, char **argv) -{ - const int N = 256; - int i; - unsigned char *h; - void *d; - - h = (unsigned char *) malloc (N); - - for (i = 0; i < N; i++) - { - h[i] = i; - } - - d = acc_copyin (h, N); - if (!d) - abort (); - - memset (&h[0], 0, N); - - fprintf (stderr, "CheCKpOInT\n"); - acc_update_self (0, N); - - for (i = 0; i < N; i++) - { - if (h[i] != i) - abort (); - } - - acc_delete (h, N); - - free (h); - - return 0; -} - -/* { dg-output "CheCKpOInT(\n|\r\n|\r).*" } */ -/* { dg-output "\\\[\[^\n\r]*,256\\\] is not mapped" } */ -/* { dg-shouldfail "" } */ diff --git a/libgomp/testsuite/libgomp.oacc-fortran/optional-cache.f95 b/libgomp/testsuite/libgomp.oacc-fortran/optional-cache.f95 new file mode 100644 index 00000000000..00f7472ae6e --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/optional-cache.f95 @@ -0,0 +1,23 @@ +! Test that the cache directives work with optional arguments. The effect +! of giving a non-present argument to the cache directive is not tested as +! it is undefined. The test is based on gfortran.dg/goacc/cache-1.f95. + +! { dg-additional-options "-std=f2008" } + +program cache_test + implicit none + integer :: d(10), e(7,13) + + call do_test(d, e) +contains + subroutine do_test(d, e) + integer, optional :: d(10), e(7,13) + integer :: i + do concurrent (i=1:5) + !$acc cache (d(1:3)) + !$acc cache (d(i:i+2)) + !$acc cache (e(1:3,2:4)) + !$acc cache (e(i:i+2,i+1:i+3)) + enddo + end +end diff --git a/libgomp/testsuite/libgomp.oacc-fortran/optional-data-copyin-by-value.f90 b/libgomp/testsuite/libgomp.oacc-fortran/optional-data-copyin-by-value.f90 new file mode 100644 index 00000000000..5cadeed44b4 --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/optional-data-copyin-by-value.f90 @@ -0,0 +1,29 @@ +! Test OpenACC data regions with optional arguments passed by value. + +! { dg-do run } + +program test + implicit none + + integer :: res + + if (foo(27) .ne. 27) stop 1 + if (foo(16, 18) .ne. 288) stop 1 +contains + function foo(x, y) + integer, value :: x + integer, value, optional :: y + integer :: res, foo + + !$acc data copyin(x, y) copyout(res) + !$acc parallel + res = x + if (present(y)) then + res = res * y + end if + !$acc end parallel + !$acc end data + + foo = res + end function foo +end program test diff --git a/libgomp/testsuite/libgomp.oacc-fortran/optional-data-copyin.f90 b/libgomp/testsuite/libgomp.oacc-fortran/optional-data-copyin.f90 new file mode 100644 index 00000000000..a30908d61a5 --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/optional-data-copyin.f90 @@ -0,0 +1,140 @@ +! Test OpenACC data regions with a copy-in of optional arguments. + +! { dg-do run } + +program test + implicit none + + integer, parameter :: n = 64 + integer :: i + integer :: a_int, b_int, c_int, res_int + integer :: a_arr(n), b_arr(n), c_arr(n), res_arr(n) + integer, allocatable :: a_alloc(:), b_alloc(:), c_alloc(:), res_alloc(:) + + a_int = 7 + b_int = 3 + c_int = 11 + + call test_int(res_int, a_int) + if (res_int .ne. a_int) stop 1 + + call test_int(res_int, a_int, b_int) + if (res_int .ne. a_int * b_int) stop 2 + + call test_int(res_int, a_int, b_int, c_int) + if (res_int .ne. a_int * b_int + c_int) stop 3 + + do i = 1, n + a_arr(i) = i + b_arr(i) = n - i + 1 + c_arr(i) = i * 3 + end do + + call test_array(res_arr, a_arr) + do i = 1, n + if (res_arr(i) .ne. a_arr(i)) stop 4 + end do + + call test_array(res_arr, a_arr, b_arr) + do i = 1, n + if (res_arr(i) .ne. a_arr(i) * b_arr(i)) stop 5 + end do + + call test_array(res_arr, a_arr, b_arr, c_arr) + do i = 1, n + if (res_arr(i) .ne. a_arr(i) * b_arr(i) + c_arr(i)) stop 6 + end do + + allocate (a_alloc(n)) + allocate (b_alloc(n)) + allocate (c_alloc(n)) + allocate (res_alloc(n)) + + do i = 1, n + a_alloc(i) = i + b_alloc(i) = n - i + 1 + c_alloc(i) = i * 3 + end do + + call test_allocatable(res_alloc, a_alloc) + do i = 1, n + if (res_alloc(i) .ne. a_alloc(i)) stop 7 + end do + + call test_allocatable(res_alloc, a_alloc, b_alloc) + do i = 1, n + if (res_alloc(i) .ne. a_alloc(i) * b_alloc(i)) stop 8 + end do + + call test_allocatable(res_alloc, a_alloc, b_alloc, c_alloc) + do i = 1, n + if (res_alloc(i) .ne. a_alloc(i) * b_alloc(i) + c_alloc(i)) stop 9 + end do + + deallocate (a_alloc) + deallocate (b_alloc) + deallocate (c_alloc) + deallocate (res_alloc) +contains + subroutine test_int(res, a, b, c) + integer :: res + integer :: a + integer, optional :: b, c + + !$acc data copyin(a, b, c) copyout(res) + !$acc parallel + res = a + + if (present(b)) res = res * b + + if (present(c)) res = res + c + !$acc end parallel + !$acc end data + end subroutine test_int + + subroutine test_array(res, a, b, c) + integer :: res(n) + integer :: a(n) + integer, optional :: b(n), c(n) + + !$acc data copyin(a, b, c) copyout(res) + !$acc parallel loop + do i = 1, n + res(i) = a(i) + end do + + !$acc parallel loop + do i = 1, n + if (present(b)) res(i) = res(i) * b(i) + end do + + !$acc parallel loop + do i = 1, n + if (present(c)) res(i) = res(i) + c(i) + end do + !$acc end data + end subroutine test_array + + subroutine test_allocatable(res, a, b, c) + integer, allocatable :: res(:) + integer, allocatable :: a(:) + integer, allocatable, optional :: b(:), c(:) + + !$acc data copyin(a, b, c) copyout(res) + !$acc parallel loop + do i = 1, n + res(i) = a(i) + end do + + !$acc parallel loop + do i = 1, n + if (present(b)) res(i) = res(i) * b(i) + end do + + !$acc parallel loop + do i = 1, n + if (present(c)) res(i) = res(i) + c(i) + end do + !$acc end data + end subroutine test_allocatable +end program test diff --git a/libgomp/testsuite/libgomp.oacc-fortran/optional-data-copyout.f90 b/libgomp/testsuite/libgomp.oacc-fortran/optional-data-copyout.f90 new file mode 100644 index 00000000000..feaa31fa423 --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/optional-data-copyout.f90 @@ -0,0 +1,96 @@ +! Test OpenACC data regions with a copy-out of optional arguments. + +! { dg-do run } + +program test + implicit none + + integer, parameter :: n = 64 + integer :: i + integer :: a_int, b_int, res_int + integer :: a_arr(n), b_arr(n), res_arr(n) + integer, allocatable :: a_alloc(:), b_alloc(:), res_alloc(:) + + res_int = 0 + + call test_int(a_int, b_int) + if (res_int .ne. 0) stop 1 + + call test_int(a_int, b_int, res_int) + if (res_int .ne. a_int * b_int) stop 2 + + res_arr(:) = 0 + do i = 1, n + a_arr(i) = i + b_arr(i) = n - i + 1 + end do + + call test_array(a_arr, b_arr) + do i = 1, n + if (res_arr(i) .ne. 0) stop 3 + end do + + call test_array(a_arr, b_arr, res_arr) + do i = 1, n + if (res_arr(i) .ne. a_arr(i) * b_arr(i)) stop 4 + end do + + allocate (a_alloc(n)) + allocate (b_alloc(n)) + allocate (res_alloc(n)) + + res_alloc(:) = 0 + do i = 1, n + a_alloc(i) = i + b_alloc(i) = n - i + 1 + end do + + call test_allocatable(a_alloc, b_alloc) + do i = 1, n + if (res_alloc(i) .ne. 0) stop 5 + end do + + call test_allocatable(a_alloc, b_alloc, res_alloc) + do i = 1, n + if (res_alloc(i) .ne. a_alloc(i) * b_alloc(i)) stop 6 + end do + + deallocate (a_alloc) + deallocate (b_alloc) + deallocate (res_alloc) +contains + subroutine test_int(a, b, res) + integer :: a, b + integer, optional :: res + + !$acc data copyin(a, b) copyout(res) + !$acc parallel + if (present(res)) res = a * b + !$acc end parallel + !$acc end data + end subroutine test_int + + subroutine test_array(a, b, res) + integer :: a(n), b(n) + integer, optional :: res(n) + + !$acc data copyin(a, b) copyout(res) + !$acc parallel loop + do i = 1, n + if (present(res)) res(i) = a(i) * b(i) + end do + !$acc end data + end subroutine test_array + + subroutine test_allocatable(a, b, res) + integer, allocatable :: a(:), b(:) + integer, allocatable, optional :: res(:) + + !$acc data copyin(a, b) copyout(res) + !$acc parallel loop + do i = 1, n + if (present(res)) res(i) = a(i) * b(i) + end do + !$acc end data + end subroutine test_allocatable +end program test diff --git a/libgomp/testsuite/libgomp.oacc-fortran/optional-data-enter-exit.f90 b/libgomp/testsuite/libgomp.oacc-fortran/optional-data-enter-exit.f90 new file mode 100644 index 00000000000..9ed0f753ea5 --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/optional-data-enter-exit.f90 @@ -0,0 +1,91 @@ +! Test OpenACC unstructured enter data/exit data regions with optional +! arguments. + +! { dg-do run } + +program test + implicit none + + integer, parameter :: n = 64 + integer :: a(n), b(n), c(n), res(n) + integer :: x, y, z, r, i + + do i = 1, n + a(i) = i + b(i) = n - i + 1 + c(i) = i * 3 + end do + + res = test_array(a) + do i = 1, n + if (res(i) .ne. a(i)) stop 1 + end do + + res = test_array(a, b) + do i = 1, n + if (res(i) .ne. a(i) * b(i)) stop 2 + end do + + res = test_array(a, b, c) + do i = 1, n + if (res(i) .ne. a(i) * b(i) + c(i)) stop 3 + end do + + x = 7 + y = 3 + z = 11 + + r = test_int(x) + if (r .ne. x) stop 4 + + r = test_int(x, y) + if (r .ne. x * y) stop 5 + + r = test_int(x, y, z) + if (r .ne. x * y + z) stop 6 +contains + function test_array(a, b, c) + integer :: a(n) + integer, optional :: b(n), c(n) + integer :: test_array(n), res(n) + + !$acc enter data copyin(a, b, c) create(res) + !$acc parallel loop + do i = 1, n + res(i) = a(i) + end do + + !$acc parallel loop + do i = 1, n + if (present(b)) then + res(i) = res(i) * b(i) + end if + end do + + !$acc parallel loop + do i = 1, n + if (present(c)) then + res(i) = res(i) + c(i) + end if + end do + !$acc exit data copyout(res) delete(a, b, c) + + test_array = res + end function test_array + + function test_int(a, b, c) + integer :: a + integer, optional :: b, c + integer :: test_int, res + + !$acc enter data copyin(a, b, c) create(res) + !$acc parallel present(a, b, c, res) + res = a + if (present(b)) res = res * b + if (present(c)) res = res + c + !$acc end parallel + !$acc exit data copyout(res) delete(a, b, c) + + test_int = res + end function test_int +end program test diff --git a/libgomp/testsuite/libgomp.oacc-fortran/optional-declare.f90 b/libgomp/testsuite/libgomp.oacc-fortran/optional-declare.f90 new file mode 100644 index 00000000000..074e5a2abb6 --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/optional-declare.f90 @@ -0,0 +1,87 @@ +! Test OpenACC declare directives with optional arguments. + +! { dg-do run } + +program test + implicit none + + integer, parameter :: n = 64 + integer :: i + integer :: a_int, b_int, c_int, res_int + integer :: a_arr(n), b_arr(n), c_arr(n), res_arr(n) + + a_int = 7 + b_int = 3 + c_int = 11 + + call test_int(res_int, a_int) + if (res_int .ne. a_int) stop 1 + + call test_int(res_int, a_int, b_int) + if (res_int .ne. a_int * b_int) stop 2 + + call test_int(res_int, a_int, b_int, c_int) + if (res_int .ne. a_int * b_int + c_int) stop 3 + + do i = 1, n + a_arr(i) = i + b_arr(i) = n - i + 1 + c_arr(i) = i * 3 + end do + + call test_array(res_arr, a_arr) + do i = 1, n + if (res_arr(i) .ne. a_arr(i)) stop 4 + end do + + call test_array(res_arr, a_arr, b_arr) + do i = 1, n + if (res_arr(i) .ne. a_arr(i) * b_arr(i)) stop 5 + end do + + call test_array(res_arr, a_arr, b_arr, c_arr) + do i = 1, n + if (res_arr(i) .ne. a_arr(i) * b_arr(i) + c_arr(i)) stop 6 + end do +contains + subroutine test_int(res, a, b, c) + integer :: a + integer, optional :: b, c + !$acc declare present_or_copyin(a, b, c) + integer :: res + !$acc declare present_or_copyout(res) + + !$acc parallel + res = a + if (present(b)) res = res * b + if (present(c)) res = res + c + !$acc end parallel + end subroutine test_int + + subroutine test_array(res, a, b, c) + integer :: a(n) + integer, optional :: b(n), c(n) + !$acc declare present_or_copyin(a, b, c) + integer :: res(n) + !$acc declare present_or_copyout(res) + + !$acc parallel loop + do i = 1, n + res(i) = a(i) + end do + + !$acc parallel loop + do i = 1, n + if (present(b)) then + res(i) = res(i) * b(i) + end if + end do + + !$acc parallel loop + do i = 1, n + if (present(c)) then + res(i) = res(i) + c(i) + end if + end do + end subroutine test_array +end program test diff --git a/libgomp/testsuite/libgomp.oacc-fortran/optional-firstprivate.f90 b/libgomp/testsuite/libgomp.oacc-fortran/optional-firstprivate.f90 new file mode 100644 index 00000000000..693e6118489 --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/optional-firstprivate.f90 @@ -0,0 +1,112 @@ +! Test that optional arguments work in firstprivate clauses. The effect of +! non-present arguments in firstprivate clauses is undefined, and is not +! tested for. + +! { dg-do run } + +program test_firstprivate + implicit none + integer, parameter :: n = 64 + + integer :: i, j + integer :: a_int, b_int, c_int, res_int + integer :: a_arr(n), b_arr(n), c_arr(n), res_arr(n) + integer, allocatable :: a_alloc(:), b_alloc(:), c_alloc(:), res_alloc(:) + + a_int = 14 + b_int = 5 + c_int = 12 + + call test_int(res_int, a_int, b_int, c_int) + if (res_int .ne. a_int * b_int + c_int) stop 1 + + do i = 1, n + a_arr(i) = i + b_arr(i) = n - i + 1 + c_arr(i) = i * 3 + end do + + call test_array(res_arr, a_arr, b_arr, c_arr) + do i = 1, n + if (res_arr(i) .ne. a_arr(i) * b_arr(i) + c_arr(i)) stop 2 + end do + + allocate(a_alloc(n)) + allocate(b_alloc(n)) + allocate(c_alloc(n)) + allocate(res_alloc(n)) + + do i = 1, n + a_arr(i) = i + b_arr(i) = n - i + 1 + c_arr(i) = i * 3 + end do + + call test_allocatable(res_alloc, a_alloc, b_alloc, c_alloc) + do i = 1, n + if (res_alloc(i) .ne. a_alloc(i) * b_alloc(i) + c_alloc(i)) stop 2 + end do + + deallocate(a_alloc) + deallocate(b_alloc) + deallocate(c_alloc) + deallocate(res_alloc) +contains + subroutine test_int(res, a, b, c) + integer :: a + integer, optional :: b, c + integer :: res + + !$acc parallel firstprivate(a, b, c) copyout(res) + res = a + if (present(b)) res = res * b + if (present(c)) res = res + c + !$acc end parallel + end subroutine test_int + + subroutine test_array(res, a, b, c) + integer :: a(n) + integer, optional :: b(n), c(n) + integer :: res(n) + + !$acc data copyin(a, b, c) copyout(res) + !$acc parallel loop firstprivate(a) + do i = 1, n + res(i) = a(i) + end do + + !$acc parallel loop firstprivate(b) + do i = 1, n + if (present(b)) res(i) = res(i) * b(i) + end do + + !$acc parallel loop firstprivate(c) + do i = 1, n + if (present(c)) res(i) = res(i) + c(i) + end do + !$acc end data + end subroutine test_array + + subroutine test_allocatable(res, a, b, c) + integer, allocatable :: a(:) + integer, allocatable, optional :: b(:), c(:) + integer, allocatable :: res(:) + + !$acc data copyin(a, b, c) copyout(res) + !$acc parallel loop firstprivate(a) + do i = 1, n + res(i) = a(i) + end do + + !$acc parallel loop firstprivate(b) + do i = 1, n + if (present(b)) res(i) = res(i) * b(i) + end do + + !$acc parallel loop firstprivate(c) + do i = 1, n + if (present(c)) res(i) = res(i) + c(i) + end do + !$acc end data + end subroutine test_allocatable +end program test_firstprivate diff --git a/libgomp/testsuite/libgomp.oacc-fortran/optional-host_data.f90 b/libgomp/testsuite/libgomp.oacc-fortran/optional-host_data.f90 new file mode 100644 index 00000000000..a6e41e28b0b --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/optional-host_data.f90 @@ -0,0 +1,39 @@ +! Test the host_data construct with optional arguments. +! Based on host_data-1.f90. + +! { dg-do run } +! { dg-additional-options "-cpp" } + +program test + implicit none + + integer, target :: i + integer, pointer :: ip, iph + + ! Assign the same targets + ip => i + iph => i + + call foo(iph) + call foo(iph, ip) +contains + subroutine foo(iph, ip) + integer, pointer :: iph + integer, pointer, optional :: ip + + !$acc data copyin(i) + !$acc host_data use_device(ip) + + ! Test how the pointers compare inside a host_data construct + if (present(ip)) then +#if ACC_MEM_SHARED + if (.not. associated(ip, iph)) STOP 1 +#else + if (associated(ip, iph)) STOP 2 +#endif + end if + + !$acc end host_data + !$acc end data + end subroutine foo +end program test diff --git a/libgomp/testsuite/libgomp.oacc-fortran/optional-nested-calls.f90 b/libgomp/testsuite/libgomp.oacc-fortran/optional-nested-calls.f90 new file mode 100644 index 00000000000..279139f7c59 --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/optional-nested-calls.f90 @@ -0,0 +1,135 @@ +! Test propagation of optional arguments from within an OpenACC parallel region. + +! { dg-do run } + +program test + implicit none + + integer, parameter :: n = 64 + integer :: i + integer :: res_int + integer :: a_arr(n), b_arr(n), res_arr(n) + integer, allocatable :: a_alloc(:), b_alloc(:), res_alloc(:) + + call test_int_caller(res_int, 5) + if (res_int .ne. 10) stop 1 + + call test_int_caller(res_int, 2, 3) + if (res_int .ne. 11) stop 2 + + do i = 1, n + a_arr(i) = i + b_arr(i) = n - i + 1 + end do + + call test_array_caller(res_arr, a_arr) + do i = 1, n + if (res_arr(i) .ne. 2 * a_arr(i)) stop 3 + end do + + call test_array_caller(res_arr, a_arr, b_arr) + do i = 1, n + if (res_arr(i) .ne. a_arr(i) * b_arr(i) + a_arr(i) + b_arr(i)) stop 4 + end do + + allocate(a_alloc(n)) + allocate(b_alloc(n)) + allocate(res_alloc(n)) + + do i = 1, n + a_alloc(i) = i + b_alloc(i) = n - i + 1 + end do + + call test_array_caller(res_arr, a_arr) + do i = 1, n + if (res_arr(i) .ne. 2 * a_alloc(i)) stop 5 + end do + + call test_array_caller(res_arr, a_arr, b_arr) + do i = 1, n + if (res_arr(i) .ne. a_arr(i) * b_alloc(i) + a_alloc(i) + b_alloc(i)) stop 6 + end do + + deallocate(a_alloc) + deallocate(b_alloc) + deallocate(res_alloc) +contains + subroutine test_int_caller(res, a, b) + integer :: res, a + integer, optional :: b + + !$acc data copyin(a, b) copyout (res) + !$acc parallel + res = a + if (present(b)) res = res * b + call test_int_callee(res, a, b) + !$acc end parallel + !$acc end data + end subroutine test_int_caller + + subroutine test_int_callee(res, a, b) + !$acc routine seq + integer :: res, a + integer, optional :: b + + res = res + a + if (present(b)) res = res + b + end subroutine test_int_callee + + subroutine test_array_caller(res, a, b) + integer :: res(n), a(n), i + integer, optional :: b(n) + + !$acc data copyin(a, b) copyout(res) + !$acc parallel + !$acc loop seq + do i = 1, n + res(i) = a(i) + if (present(b)) res(i) = res(i) * b(i) + end do + call test_array_callee(res, a, b) + !$acc end parallel + !$acc end data + end subroutine test_array_caller + + subroutine test_array_callee(res, a, b) + !$acc routine seq + integer :: res(n), a(n), i + integer, optional :: b(n) + + do i = 1, n + res(i) = res(i) + a(i) + if (present(b)) res(i) = res(i) + b(i) + end do + end subroutine test_array_callee + + subroutine test_allocatable_caller(res, a, b) + integer :: i + integer, allocatable :: res(:), a(:) + integer, allocatable, optional :: b(:) + + !$acc data copyin(a, b) copyout(res) + !$acc parallel + !$acc loop seq + do i = 1, n + res(i) = a(i) + if (present(b)) res(i) = res(i) * b(i) + end do + call test_array_callee(res, a, b) + !$acc end parallel + !$acc end data + end subroutine test_allocatable_caller + + subroutine test_allocatable_callee(res, a, b) + !$acc routine seq + integer :: i + integer, allocatable :: res(:), a(:) + integer, allocatable, optional :: b(:) + + do i = 1, n + res(i) = res(i) + a(i) + if (present(b)) res(i) = res(i) + b(i) + end do + end subroutine test_allocatable_callee +end program test diff --git a/libgomp/testsuite/libgomp.oacc-fortran/optional-private.f90 b/libgomp/testsuite/libgomp.oacc-fortran/optional-private.f90 new file mode 100644 index 00000000000..0320bbb3bc9 --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/optional-private.f90 @@ -0,0 +1,115 @@ +! Test that optional arguments work in private clauses. The effect of +! non-present arguments in private clauses is undefined, and is not tested +! for. The tests are based on those in private-variables.f90. + +! { dg-do run } + +program main + implicit none + + type vec3 + integer x, y, z, attr(13) + end type vec3 + integer :: x + type(vec3) :: pt + integer :: arr(2) + + call t1(x) + call t2(pt) + call t3(arr) +contains + + ! Test of gang-private variables declared on loop directive. + + subroutine t1(x) + integer, optional :: x + integer :: i, arr(32) + + do i = 1, 32 + arr(i) = i + end do + + !$acc parallel copy(arr) num_gangs(32) num_workers(8) vector_length(32) + !$acc loop gang private(x) + do i = 1, 32 + x = i * 2; + arr(i) = arr(i) + x + end do + !$acc end parallel + + do i = 1, 32 + if (arr(i) .ne. i * 3) STOP 1 + end do + end subroutine t1 + + + ! Test of gang-private addressable variable declared on loop directive, with + ! broadcasting to partitioned workers. + + subroutine t2(pt) + integer i, j, arr(0:32*32) + type(vec3), optional :: pt + + do i = 0, 32*32-1 + arr(i) = i + end do + + !$acc parallel copy(arr) num_gangs(32) num_workers(8) vector_length(32) + !$acc loop gang private(pt) + do i = 0, 31 + pt%x = i + pt%y = i * 2 + pt%z = i * 4 + pt%attr(5) = i * 6 + + !$acc loop vector + do j = 0, 31 + arr(i * 32 + j) = arr(i * 32 + j) + pt%x + pt%y + pt%z + pt%attr(5); + end do + end do + !$acc end parallel + + do i = 0, 32 * 32 - 1 + if (arr(i) .ne. i + (i / 32) * 13) STOP 2 + end do + end subroutine t2 + + ! Test of vector-private variables declared on loop directive. Array type. + + subroutine t3(pt) + integer, optional :: pt(2) + integer :: i, j, k, idx, arr(0:32*32*32) + + do i = 0, 32*32*32-1 + arr(i) = i + end do + + !$acc parallel copy(arr) num_gangs(32) num_workers(8) vector_length(32) + !$acc loop gang + do i = 0, 31 + !$acc loop worker + do j = 0, 31 + !$acc loop vector private(pt) + do k = 0, 31 + pt(1) = ieor(i, j * 3) + pt(2) = ior(i, j * 5) + arr(i * 1024 + j * 32 + k) = arr(i * 1024 + j * 32 + k) + pt(1) * k + arr(i * 1024 + j * 32 + k) = arr(i * 1024 + j * 32 + k) + pt(2) * k + end do + end do + end do + !$acc end parallel + + do i = 0, 32 - 1 + do j = 0, 32 -1 + do k = 0, 32 - 1 + idx = i * 1024 + j * 32 + k + if (arr(idx) .ne. idx + ieor(i, j * 3) * k + ior(i, j * 5) * k) then + STOP 3 + end if + end do + end do + end do + end subroutine t3 + +end program main diff --git a/libgomp/testsuite/libgomp.oacc-fortran/optional-reduction.f90 b/libgomp/testsuite/libgomp.oacc-fortran/optional-reduction.f90 new file mode 100644 index 00000000000..b76db3ef6d3 --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/optional-reduction.f90 @@ -0,0 +1,69 @@ +! Test optional arguments in reduction clauses. The effect of +! non-present arguments in reduction clauses is undefined, and is not tested +! for. The tests are based on those in reduction-1.f90. + +! { dg-do run } +! { dg-additional-options "-w" } + +program optional_reduction + implicit none + + integer :: rg, rw, rv, rc + + rg = 0 + rw = 0 + rv = 0 + rc = 0 + + call do_test(rg, rw, rv, rc) +contains + subroutine do_test(rg, rw, rv, rc) + integer, parameter :: n = 10, ng = 8, nw = 4, vl = 32 + integer, optional :: rg, rw, rv, rc + integer :: i, vresult + integer, dimension (n) :: array + + vresult = 0 + do i = 1, n + array(i) = i + end do + + !$acc parallel num_gangs(ng) copy(rg) + !$acc loop reduction(+:rg) gang + do i = 1, n + rg = rg + array(i) + end do + !$acc end parallel + + !$acc parallel num_workers(nw) copy(rw) + !$acc loop reduction(+:rw) worker + do i = 1, n + rw = rw + array(i) + end do + !$acc end parallel + + !$acc parallel vector_length(vl) copy(rv) + !$acc loop reduction(+:rv) vector + do i = 1, n + rv = rv + array(i) + end do + !$acc end parallel + + !$acc parallel num_gangs(ng) num_workers(nw) vector_length(vl) copy(rc) + !$acc loop reduction(+:rc) gang worker vector + do i = 1, n + rc = rc + array(i) + end do + !$acc end parallel + + ! Verify the results + do i = 1, n + vresult = vresult + array(i) + end do + + if (rg .ne. vresult) STOP 1 + if (rw .ne. vresult) STOP 2 + if (rv .ne. vresult) STOP 3 + if (rc .ne. vresult) STOP 4 + end subroutine do_test +end program optional_reduction diff --git a/libgomp/testsuite/libgomp.oacc-fortran/optional-update-device.f90 b/libgomp/testsuite/libgomp.oacc-fortran/optional-update-device.f90 new file mode 100644 index 00000000000..57f69001d3d --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/optional-update-device.f90 @@ -0,0 +1,121 @@ +! Test OpenACC update to device with an optional argument. + +! { dg-do run } + +program optional_update_device + implicit none + + integer, parameter :: n = 64 + integer :: i + integer :: a_int, b_int, res_int + integer :: a_arr(n), b_arr(n), res_arr(n) + integer, allocatable :: a_alloc(:), b_alloc(:), res_alloc(:) + + a_int = 5 + b_int = 11 + + call test_int(res_int, a_int) + if (res_int .ne. a_int) stop 1 + + call test_int(res_int, a_int, b_int) + if (res_int .ne. a_int * b_int) stop 2 + + res_arr(:) = 0 + do i = 1, n + a_arr(i) = i + b_arr(i) = n - i + 1 + end do + + call test_array(res_arr, a_arr) + do i = 1, n + if (res_arr(i) .ne. a_arr(i)) stop 3 + end do + + call test_array(res_arr, a_arr, b_arr) + do i = 1, n + if (res_arr(i) .ne. a_arr(i) * b_arr(i)) stop 4 + end do + + allocate (a_alloc(n)) + allocate (b_alloc(n)) + allocate (res_alloc(n)) + + res_alloc(:) = 0 + do i = 1, n + a_alloc(i) = i + b_alloc(i) = n - i + 1 + end do + + call test_allocatable(res_alloc, a_alloc) + do i = 1, n + if (res_alloc(i) .ne. a_alloc(i)) stop 5 + end do + + call test_allocatable(res_alloc, a_alloc, b_alloc) + do i = 1, n + if (res_alloc(i) .ne. a_alloc(i) * b_alloc(i)) stop 6 + end do + + deallocate (a_alloc) + deallocate (b_alloc) + deallocate (res_alloc) +contains + subroutine test_int(res, a, b) + integer :: res + integer :: a + integer, optional :: b + + !$acc data create(a, b, res) + !$acc update device(a, b) + !$acc parallel + res = a + if (present(b)) res = res * b + !$acc end parallel + !$acc update self(res) + !$acc end data + end subroutine test_int + + subroutine test_array(res, a, b) + integer :: res(n) + integer :: a(n) + integer, optional :: b(n) + + !$acc data create(a, b, res) + !$acc update device(a, b) + !$acc parallel loop + do i = 1, n + res(i) = a(i) + end do + + !$acc parallel loop + do i = 1, n + if (present(b)) then + res(i) = res(i) * b(i) + end if + end do + !$acc update self(res) + !$acc end data + end subroutine test_array + + subroutine test_allocatable(res, a, b) + integer, allocatable :: res(:) + integer, allocatable :: a(:) + integer, allocatable, optional :: b(:) + + !$acc data create(a, b, res) + !$acc update device(a, b) + !$acc parallel loop + do i = 1, n + res(i) = a(i) + end do + + !$acc parallel loop + do i = 1, n + if (present(b)) then + res(i) = res(i) * b(i) + end if + end do + !$acc update self(res) + !$acc end data + end subroutine test_allocatable +end program optional_update_device diff --git a/libgomp/testsuite/libgomp.oacc-fortran/optional-update-host.f90 b/libgomp/testsuite/libgomp.oacc-fortran/optional-update-host.f90 new file mode 100644 index 00000000000..36b94241b11 --- /dev/null +++ b/libgomp/testsuite/libgomp.oacc-fortran/optional-update-host.f90 @@ -0,0 +1,115 @@ +! Test OpenACC update to host with an optional argument. + +! { dg-do run } + +program optional_update_host + implicit none + + integer, parameter :: n = 64 + integer :: i + integer :: a_int, b_int, res_int + integer :: a_arr(n), b_arr(n), res_arr(n) + integer, allocatable :: a_alloc(:), b_alloc(:), res_alloc(:) + + a_int = 5 + b_int = 11 + res_int = 0 + + call test_int(a_int, b_int) + if (res_int .ne. 0) stop 1 + + call test_int(a_int, b_int, res_int) + if (res_int .ne. a_int * b_int) stop 2 + + res_arr(:) = 0 + do i = 1, n + a_arr(i) = i + b_arr(i) = n - i + 1 + end do + + call test_array(a_arr, b_arr) + do i = 1, n + if (res_arr(i) .ne. 0) stop 1 + end do + + call test_array(a_arr, b_arr, res_arr) + do i = 1, n + if (res_arr(i) .ne. a_arr(i) * b_arr(i)) stop 2 + end do + + allocate(a_alloc(n)) + allocate(b_alloc(n)) + allocate(res_alloc(n)) + + res_alloc(:) = 0 + do i = 1, n + a_alloc(i) = i + b_alloc(i) = n - i + 1 + end do + + call test_allocatable(a_alloc, b_alloc) + do i = 1, n + if (res_alloc(i) .ne. 0) stop 1 + end do + + call test_allocatable(a_alloc, b_alloc, res_alloc) + do i = 1, n + if (res_alloc(i) .ne. a_alloc(i) * b_alloc(i)) stop 2 + end do + + deallocate(a_alloc) + deallocate(b_alloc) + deallocate(res_alloc) +contains + subroutine test_int(a, b, res) + integer :: a, b + integer, optional :: res + + !$acc data create(a, b, res) + !$acc update device(a, b) + !$acc parallel + if (present(res)) res = a + if (present(res)) res = res * b + !$acc end parallel + !$acc update self(res) + !$acc end data + end subroutine test_int + + subroutine test_array(a, b, res) + integer :: a(n), b(n) + integer, optional :: res(n) + + !$acc data create(a, b, res) + !$acc update device(a, b) + !$acc parallel loop + do i = 1, n + if (present(res)) res(i) = a(i) + end do + + !$acc parallel loop + do i = 1, n + if (present(res)) res(i) = res(i) * b(i) + end do + !$acc update self(res) + !$acc end data + end subroutine test_array + + subroutine test_allocatable(a, b, res) + integer, allocatable :: a(:), b(:) + integer, allocatable, optional :: res(:) + + !$acc data create(a, b, res) + !$acc update device(a, b) + !$acc parallel loop + do i = 1, n + if (present(res)) res(i) = a(i) + end do + + !$acc parallel loop + do i = 1, n + if (present(res)) res(i) = res(i) * b(i) + end do + !$acc update self(res) + !$acc end data + end subroutine test_allocatable +end program optional_update_host