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
* primary.c (gfc_match_rvalue): Add some flavor checks
gfc_matching_procptr_assignment.
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)
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;
}
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)
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
}
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)
&& !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;
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,
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);
|| 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);
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,
{
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;
}
+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.
! { 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()
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
--- /dev/null
+! 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
projects / platform / upstream / gcc.git / commitdiff