Fortran] OpenMP/OpenACC – fix more issues with OPTIONAL
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
This commit is contained in:
Tobias Burnus
Tobias Burnus
parent
1609beddb1
commit
f760c0c77f
|
|
@ -1,3 +1,13 @@
|
|||
2020-01-03 Tobias Burnus <tobias@codesourcery.com>
|
||||
|
||||
* 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 <tobias@codesourcery.com>
|
||||
|
||||
PR fortran/92994
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,3 +1,11 @@
|
|||
2020-01-03 Tobias Burnus <tobias@codesourcery.com>
|
||||
|
||||
* 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 <jakub@redhat.com>
|
||||
|
||||
Update copyright years.
|
||||
|
|
|
|||
|
|
@ -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()
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
Loading…
Reference in New Issue