OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Fortran] OpenMP/OpenACC – fix more issues with OPTIONAL

Browse Source 
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 2020-01-03 12:56:46 +00:00 committed by Tobias Burnus
parent 1609beddb1
commit f760c0c77f
6 changed files with 260 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
gcc/fortran/ChangeLog
View File

@ -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

117
gcc/fortran/trans-openmp.c
View File

@ -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;
}

8
libgomp/ChangeLog
View File

@ -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.

13
libgomp/testsuite/libgomp.fortran/optional-map.f90
View File

@ -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()

11
libgomp/testsuite/libgomp.fortran/use_device_ptr-optional-2.f90
View File

@ -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

140
libgomp/testsuite/libgomp.fortran/use_device_ptr-optional-3.f90 Normal file
View File

@ -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