From f760c0c77fe350616da9dbeaea16442b0acfb09c Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Fri, 3 Jan 2020 12:56:46 +0000 Subject: [PATCH] =?utf8?q?Fortran]=20OpenMP/OpenACC=20=E2=80=93=20fix=20mo?= =?utf8?q?re=20issues=20with=20OPTIONAL?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit 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. From-SVN: r279858 --- gcc/fortran/ChangeLog | 10 ++ gcc/fortran/trans-openmp.c | 117 ++++++++++----- libgomp/ChangeLog | 8 + .../libgomp.fortran/optional-map.f90 | 13 ++ .../use_device_ptr-optional-2.f90 | 11 ++ .../use_device_ptr-optional-3.f90 | 140 ++++++++++++++++++ 6 files changed, 260 insertions(+), 39 deletions(-) create mode 100644 libgomp/testsuite/libgomp.fortran/use_device_ptr-optional-3.f90 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 7f1bdc04be1..19397d65353 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,13 @@ +2020-01-03 Tobias Burnus + + * 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. + 2020-01-03 Tobias Burnus PR fortran/92994 diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 553d4cb0891..918af74bbf6 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; } @@ -1192,7 +1213,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) @@ -1201,15 +1222,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 @@ -1260,8 +1275,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) @@ -1271,6 +1285,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; @@ -1378,10 +1409,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, @@ -2468,9 +2497,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 (n->sym->ts.type == BT_CLASS) { tree type = TREE_TYPE (decl); @@ -2509,6 +2536,30 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses, || n->sym->ts.type == BT_DERIVED)) { 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); @@ -2588,17 +2639,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, @@ -2617,16 +2661,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/ChangeLog b/libgomp/ChangeLog index 4f9133125ac..a204585d7b8 100644 --- a/libgomp/ChangeLog +++ b/libgomp/ChangeLog @@ -1,3 +1,11 @@ +2020-01-03 Tobias Burnus + + * 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. + 2020-01-01 Jakub Jelinek Update copyright years. 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 -- 2.30.2