From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: (qmail 77066 invoked by alias); 10 Dec 2019 17:54:31 -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 75943 invoked by uid 89); 10 Dec 2019 17:54:31 -0000 Authentication-Results: sourceware.org; auth=none X-Spam-SWARE-Status: No, score=-16.9 required=5.0 tests=AWL,BAYES_00,GARBLED_SUBJECT,GIT_PATCH_0,GIT_PATCH_1,GIT_PATCH_2,GIT_PATCH_3,KAM_SHORT,SPF_PASS autolearn=ham version=3.3.1 spammy=tons, sk:build_o, 3,4, transopenmpc X-HELO: esa2.mentor.iphmx.com Received: from esa2.mentor.iphmx.com (HELO esa2.mentor.iphmx.com) (68.232.141.98) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Tue, 10 Dec 2019 17:54:28 +0000 IronPort-SDR: p23G9CURzaiJ6VF9yO2i5iXOFOBBA3O5p6KRFwmNoFEWUA4ezwXyyCkqabwVLfIIn3eoi1npfz SClDBTuNQXKzDlADOxTPQ8r8FRtRtp0SnkFDxBPgAwB1EIV58ffSrHbLC/QuFMvqDYg+EO0BCo aVtkwFBrJ3tZy9QDYYwAdNw4Z4W+k/wYozzY4+A39XMll5ZhZkil+5WCI73bUOdR9jBbQqrmzJ vdS6OmZr4FcIEYCrZx5dzHMCv4KO32MxOK9varLfKdw0EkkTtwcJqbbqNYll6pp1yTcxq3Jhof 30E= Received: from orw-gwy-01-in.mentorg.com ([192.94.38.165]) by esa2.mentor.iphmx.com with ESMTP; 10 Dec 2019 09:54:26 -0800 IronPort-SDR: 4eRH5i2qk9Qvqqm4pRBjbIJZFGtUI+ZI9+Z7w1btZbeYQprMR5R+dTT4wRVx50VPx+MB5zObGA vrLEcZYb0DBzGYgSflNhuMWkWsqqpVsxPi2SIL8YYQ+KFiaZXDwjNyYQ52fLZaeG7qtgDSvOc6 Tod5817mCBSC6QAjzi06/Lzt+6hXD7aUHN3s9zX70I+HvYS1umtdI8c+x5CA0CUVbTQd81k4NF 3e+QTQQqXBs+tg6V75fMzFYOjiXeogTbB5nvcEWQyrMb0EyGehCkOgmQx1QLIhyp/qxT6gPJyA BAg= To: gcc-patches , fortran , Jakub Jelinek , Thomas Schwinge From: Tobias Burnus Subject: =?UTF-8?Q?=5bPatch=2c_Fortran=5d_OpenMP/OpenACC_=e2=80=93_fix_more_?= =?UTF-8?Q?issues_with_OPTIONAL?= Message-ID: <01b9ed0e-aee8-b12a-c293-b057d71fac21@codesourcery.com> Date: Tue, 10 Dec 2019 17:54:00 -0000 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:68.0) Gecko/20100101 Thunderbird/68.2.2 MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="------------AEAE062E0A5DAF2B48E731EC" Return-Path: tobias@codesourcery.com X-IsSubscribed: yes X-SW-Source: 2019-12/txt/msg00707.txt.bz2 --------------AEAE062E0A5DAF2B48E731EC Content-Type: text/plain; charset="utf-8"; format=flowed Content-Transfer-Encoding: 8bit Content-length: 1612 Nonallocatable, nonpointer array arguments (of assumed shape) are special as they get a get an array descriptor ('arg') as argument but create a local variable which accesses the actual data ('arg.0 = arg->data'). With OPTIONAL, there are/were two outstanding issues: (A) If the argument is not present, 'arg.0' is/was never assigned to. (B) The optional-arg-is-present check is not just 'if (arg)' but 'if (arg && arg->data)' as passing an unallocated allocatable/disassociated pointer (i.e. 'arg->data = NULL') to a nonpointer, nonallocatable optional dummy argument counts as absent argument; this affects (A). Solution: (B) is now solved by updating what gfc_omp_check_optional_argument returns; as is now always returns an boolean_type_node, one can clean up the code which adds "!= NULL" when using the "present" tree variable. (A) For mapping, one also does GOMP_MAP_POINTER; if one replaces this by a temporary variable 'D.124 = present ? arg.0 : NULL', it will later ICE in omp-low.c one confuses the identifier handling, which replaces the variables in 'target (data)'. Build on x86-64-gnu-linux w/o offloading and on one nvptx configuration with actual offloading. OK? Tobias PS: Besides adding tons of test cases, it also fixes the transient issue (which does only occur with -O1 ?!?) with the existing use_device_addr-{3,4}.f90 test case. That failed due to reason (A). – Cf. https://gcc.gnu.org/ml/gcc-patches/2019-12/msg00499.html PPS: I haven't tried polymorphic data types but I am positive they will fail. Cray pointers are also candidates for additional failures. --------------AEAE062E0A5DAF2B48E731EC Content-Type: text/x-patch; charset="UTF-8"; name="extend-opt-mapping-v8.diff" Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename="extend-opt-mapping-v8.diff" Content-length: 16037 2019-12-10 Tobias Burnus gcc/fortran/ * trans-openmp.c (gfc_omp_check_optional_argument): Always return a Boolean expression; handle unallocated/disassociated actual arguments as absent if passed to nonallocatable/nonpointer dummy array arguments. (gfc_build_cond_assign): Change to assume a Boolean expr not a pointer. (gfc_omp_finish_clause, gfc_trans_omp_clauses): Assign NULL to generated array-data variable if the argument is absent. Simplify code as 'present' is now a Boolean expression. libgomp/ * testsuite/libgomp.fortran/optional-map.f90: Add test for unallocated/disassociated actual arguments to nonallocatable/nonpointer dummy arguments; those are/shall be regarded as absent arguments. * testsuite/libgomp.fortran/use_device_ptr-optional-2.f90: Ditto. * testsuite/libgomp.fortran/use_device_ptr-optional-3.f90: New. gcc/fortran/trans-openmp.c | 117 +++++++++++------ libgomp/testsuite/libgomp.fortran/optional-map.f90 | 13 ++ .../libgomp.fortran/use_device_ptr-optional-2.f90 | 11 ++ .../libgomp.fortran/use_device_ptr-optional-3.f90 | 140 +++++++++++++++++++++ 4 files changed, 242 insertions(+), 39 deletions(-) diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 356fd04e6c3..e46086d3916 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -90,11 +90,16 @@ gfc_omp_check_optional_argument (tree decl, bool for_present_check) if (!DECL_LANG_SPECIFIC (decl)) return NULL_TREE; + bool is_array_type = false; + /* For assumed-shape arrays, a local decl with arg->data is used. */ if (TREE_CODE (decl) != PARM_DECL && (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (decl)) || GFC_ARRAY_TYPE_P (TREE_TYPE (decl)))) - decl = GFC_DECL_SAVED_DESCRIPTOR (decl); + { + is_array_type = true; + decl = GFC_DECL_SAVED_DESCRIPTOR (decl); + } if (TREE_CODE (decl) != PARM_DECL || !DECL_LANG_SPECIFIC (decl) @@ -126,7 +131,23 @@ gfc_omp_check_optional_argument (tree decl, bool for_present_check) return decl; } - return decl; + tree cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + decl, null_pointer_node); + + /* Fortran regards unallocated allocatables/disassociated pointer which + are passed to a nonallocatable, nonpointer argument as not associated; + cf. F2018, 15.5.2.12, Paragraph 1. */ + if (is_array_type) + { + tree cond2 = build_fold_indirect_ref_loc (input_location, decl); + cond2 = gfc_conv_array_data (cond2); + cond2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, + cond2, null_pointer_node); + cond = fold_build2_loc (input_location, TRUTH_ANDIF_EXPR, + boolean_type_node, cond, cond2); + } + + return cond; } @@ -1189,7 +1210,7 @@ gfc_build_cond_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 else_b = NULL_TREE; tree val_ty = TREE_TYPE (val); if (else_val) @@ -1198,15 +1219,9 @@ gfc_build_cond_assign (stmtblock_t *block, tree val, tree cond_val, 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)); + build3_loc (input_location, COND_EXPR, void_type_node, + cond_val, then_b, else_b)); } /* Build a conditional expression in BLOCK, returning a temporary @@ -1257,8 +1272,7 @@ 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); + tree present = gfc_omp_check_optional_argument (decl, true); if (POINTER_TYPE_P (TREE_TYPE (decl))) { if (!gfc_omp_privatize_by_reference (decl) @@ -1268,6 +1282,23 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p) && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))) return; tree orig_decl = decl; + + /* For nonallocatable, nonpointer arrays, a temporary variable is + generated, but this one is only defined if the variable is present; + hence, we now set it to NULL to avoid accessing undefined variables. + We cannot use a temporary variable here as otherwise the replacement + of the variables in omp-low.c will not work. */ + if (present && GFC_ARRAY_TYPE_P (TREE_TYPE (decl))) + { + tree tmp = fold_build2_loc (input_location, MODIFY_EXPR, + void_type_node, decl, null_pointer_node); + tree cond = fold_build1_loc (input_location, TRUTH_NOT_EXPR, + boolean_type_node, present); + tmp = build3_loc (input_location, COND_EXPR, void_type_node, + cond, tmp, NULL_TREE); + gimplify_and_add (tmp, pre_p); + } + c4 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP); OMP_CLAUSE_SET_MAP_KIND (c4, GOMP_MAP_POINTER); OMP_CLAUSE_DECL (c4) = decl; @@ -1375,10 +1406,8 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p) 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); + boolean_type_node, present, cond); } gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR, void_type_node, cond, @@ -2380,9 +2409,7 @@ 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); + tree present = gfc_omp_check_optional_argument (decl, true); if (POINTER_TYPE_P (TREE_TYPE (decl)) && (gfc_omp_privatize_by_reference (decl) || GFC_DECL_GET_SCALAR_POINTER (decl) @@ -2392,6 +2419,30 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, (TREE_TYPE (TREE_TYPE (decl))))) { tree orig_decl = decl; + + /* For nonallocatable, nonpointer arrays, a temporary + variable is generated, but this one is only defined if + the variable is present; hence, we now set it to NULL + to avoid accessing undefined variables. We cannot use + a temporary variable here as otherwise the replacement + of the variables in omp-low.c will not work. */ + if (present && GFC_ARRAY_TYPE_P (TREE_TYPE (decl))) + { + tree tmp = fold_build2_loc (input_location, + MODIFY_EXPR, + void_type_node, decl, + null_pointer_node); + tree cond = fold_build1_loc (input_location, + TRUTH_NOT_EXPR, + boolean_type_node, + present); + gfc_add_expr_to_block (block, + build3_loc (input_location, + COND_EXPR, + void_type_node, + cond, tmp, + NULL_TREE)); + } node4 = build_omp_clause (input_location, OMP_CLAUSE_MAP); OMP_CLAUSE_SET_MAP_KIND (node4, GOMP_MAP_POINTER); @@ -2469,17 +2520,10 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, 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); - } + cond = fold_build2_loc (input_location, + TRUTH_ANDIF_EXPR, + boolean_type_node, + present, cond); gfc_add_expr_to_block (block, build3_loc (input_location, COND_EXPR, @@ -2498,16 +2542,11 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, { 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); - cond = build3_loc (input_location, COND_EXPR, - void_type_node, cond, - gfc_finish_block (&cond_block), - NULL_TREE); + tree cond_body = gfc_finish_block (&cond_block); + tree cond = build3_loc (input_location, COND_EXPR, + void_type_node, present, + cond_body, NULL_TREE); gfc_add_expr_to_block (block, cond); OMP_CLAUSE_SIZE (node) = var; } diff --git a/libgomp/testsuite/libgomp.fortran/optional-map.f90 b/libgomp/testsuite/libgomp.fortran/optional-map.f90 index eebe58cc45c..b06efcc90d1 100644 --- a/libgomp/testsuite/libgomp.fortran/optional-map.f90 +++ b/libgomp/testsuite/libgomp.fortran/optional-map.f90 @@ -1,11 +1,24 @@ ! { dg-do run } ! implicit none (type, external) +integer, allocatable :: a_ii, a_ival, a_iarr(:) +integer, pointer :: p_ii, p_ival, p_iarr(:) + +nullify (p_ii, p_ival, p_iarr) + call sub() call sub2() call call_present_1() call call_present_2() +! unallocated/disassociated actual arguments to nonallocatable, nonpointer +! dummy arguments are regarded as absent +! Skipping 'ival' dummy argument due to PR fortran/92887 +call sub(ii=a_ii, iarr=a_iarr) +call sub(ii=p_ii, iarr=p_iarr) +call sub2(ii=a_ii, iarr=a_iarr) +call sub2(ii=p_ii, iarr=p_iarr) + contains subroutine call_present_1() diff --git a/libgomp/testsuite/libgomp.fortran/use_device_ptr-optional-2.f90 b/libgomp/testsuite/libgomp.fortran/use_device_ptr-optional-2.f90 index d33b7d1cce0..641ebd98962 100644 --- a/libgomp/testsuite/libgomp.fortran/use_device_ptr-optional-2.f90 +++ b/libgomp/testsuite/libgomp.fortran/use_device_ptr-optional-2.f90 @@ -3,8 +3,19 @@ program main use iso_c_binding, only: c_ptr, c_loc, c_associated implicit none (type, external) + integer, allocatable :: a_w, a_x(:) + integer, pointer :: p_w, p_x(:) + + nullify (p_w, p_x) call foo() + + ! unallocated/disassociated actual arguments to nonallocatable, nonpointer + ! dummy arguments are regarded as absent + call foo (w=a_w, x=a_x) + call foo (w=p_w, x=p_x) + contains + subroutine foo(v, w, x, y, z, cptr, cptr_in) integer, target, optional, value :: v integer, target, optional :: w diff --git a/libgomp/testsuite/libgomp.fortran/use_device_ptr-optional-3.f90 b/libgomp/testsuite/libgomp.fortran/use_device_ptr-optional-3.f90 new file mode 100644 index 00000000000..f2e1a60757f --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/use_device_ptr-optional-3.f90 @@ -0,0 +1,140 @@ +! Check whether absent optional arguments are properly +! handled with use_device_{addr,ptr}. +program main + use iso_c_binding, only: c_ptr, c_loc, c_associated, c_f_pointer + implicit none (type, external) + + integer, target :: u + integer, target :: v + integer, target :: w + integer, target :: x(4) + integer, target, allocatable :: y + integer, target, allocatable :: z(:) + type(c_ptr), target :: cptr + type(c_ptr), target :: cptr_in + integer :: dummy + + u = 42 + v = 5 + w = 7 + x = [3,4,6,2] + y = 88 + z = [1,2,3] + + !$omp target enter data map(to:u) + !$omp target data map(to:dummy) use_device_addr(u) + cptr_in = c_loc(u) ! Has to be outside 'foo' due to 'intent(in)' + !$omp end target data + + call foo (u, v, w, x, y, z, cptr, cptr_in) + deallocate (y, z) +contains + subroutine foo (u, v, w, x, y, z, cptr, cptr_in) + integer, target, optional, value :: v + integer, target, optional :: u, w + integer, target, optional :: x(:) + integer, target, optional, allocatable :: y + integer, target, optional, allocatable :: z(:) + type(c_ptr), target, optional, value :: cptr + type(c_ptr), target, optional, value, intent(in) :: cptr_in + integer :: d + + type(c_ptr) :: p_u, p_v, p_w, p_x, p_y, p_z, p_cptr, p_cptr_in + + !$omp target enter data map(to:w, x, y, z) + !$omp target data map(dummy) use_device_addr(x) + cptr = c_loc(x) + !$omp end target data + + ! Need to map per-VALUE arguments, if present + if (present(v)) then + !$omp target enter data map(to:v) + else + stop 1 + end if + if (present(cptr)) then + !$omp target enter data map(to:cptr) + else + stop 2 + end if + if (present(cptr_in)) then + !$omp target enter data map(to:cptr_in) + else + stop 3 + end if + + !$omp target data map(d) use_device_addr(u, v, w, x, y, z) + !$omp target data map(d) use_device_addr(cptr, cptr_in) + if (.not. present(u)) stop 10 + if (.not. present(v)) stop 11 + if (.not. present(w)) stop 12 + if (.not. present(x)) stop 13 + if (.not. present(y)) stop 14 + if (.not. present(z)) stop 15 + if (.not. present(cptr)) stop 16 + if (.not. present(cptr_in)) stop 17 + p_u = c_loc(u) + p_v = c_loc(v) + p_w = c_loc(w) + p_x = c_loc(x) + p_y = c_loc(y) + p_z = c_loc(z) + p_cptr = c_loc(cptr) + p_cptr_in = c_loc(cptr_in) + !$omp end target data + !$omp end target data + call check(p_u, p_v, p_w, p_x, p_y, p_z, p_cptr, p_cptr_in, size(x), size(z)) + end subroutine foo + + subroutine check(p_u, p_v, p_w, p_x, p_y, p_z, p_cptr, p_cptr_in, Nx, Nz) + type(c_ptr), value :: p_u, p_v, p_w, p_x, p_y, p_z, p_cptr, p_cptr_in + integer, value :: Nx, Nz + integer, pointer :: c_u(:), c_v(:), c_w(:), c_x(:), c_y(:), c_z(:) + type(c_ptr), pointer :: c_cptr(:), c_cptr_in(:) + + ! As is_device_ptr does not handle scalars, we map them to a size-1 array + call c_f_pointer(p_u, c_u, shape=[1]) + call c_f_pointer(p_v, c_v, shape=[1]) + call c_f_pointer(p_w, c_w, shape=[1]) + call c_f_pointer(p_x, c_x, shape=[Nx]) + call c_f_pointer(p_y, c_y, shape=[1]) + call c_f_pointer(p_z, c_z, shape=[Nz]) + call c_f_pointer(p_cptr, c_cptr, shape=[1]) + call c_f_pointer(p_cptr_in, c_cptr_in, shape=[1]) + call run_target(c_u, c_v, c_w, c_x, c_y, c_z, c_cptr, c_cptr_in, Nx, Nz) + end subroutine check + + subroutine run_target(c_u, c_v, c_w, c_x, c_y, c_z, c_cptr, c_cptr_in, Nx, Nz) + integer, target :: c_u(:), c_v(:), c_w(:), c_x(:), c_y(:), c_z(:) + type(c_ptr) :: c_cptr(:), c_cptr_in(:) + integer, value :: Nx, Nz + !$omp target is_device_ptr(c_u, c_v, c_w, c_x, c_y, c_z, c_cptr, c_cptr_in) map(to:Nx, Nz) + call target_fn(c_u(1), c_v(1), c_w(1), c_x, c_y(1), c_z, c_cptr(1), c_cptr_in(1), Nx, Nz) + !$omp end target + end subroutine run_target + + subroutine target_fn(c_u, c_v, c_w, c_x, c_y, c_z, c_cptr, c_cptr_in, Nx, Nz) + !$omp declare target + integer, target :: c_u, c_v, c_w, c_x(:), c_y, c_z(:) + type(c_ptr), value :: c_cptr, c_cptr_in + integer, value :: Nx, Nz + integer, pointer :: u, x(:) + if (c_u /= 42) stop 30 + if (c_v /= 5) stop 31 + if (c_w /= 7) stop 32 + if (Nx /= 4) stop 33 + if (any (c_x /= [3,4,6,2])) stop 34 + if (c_y /= 88) stop 35 + if (Nz /= 3) stop 36 + if (any (c_z /= [1,2,3])) stop 37 + if (.not. c_associated (c_cptr)) stop 38 + if (.not. c_associated (c_cptr_in)) stop 39 + if (.not. c_associated (c_cptr, c_loc(c_x))) stop 40 + if (.not. c_associated (c_cptr_in, c_loc(c_u))) stop 41 + call c_f_pointer(c_cptr_in, u) + call c_f_pointer(c_cptr, x, shape=[Nx]) + if (u /= c_u .or. u /= 42) stop 42 + if (any (x /= c_x)) stop 43 + if (any (x /= [3,4,6,2])) stop 44 + end subroutine target_fn +end program main --------------AEAE062E0A5DAF2B48E731EC--