mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-24 16:30:53 +08:00
Code Issues Packages Projects Releases Wiki Activity

[OpenMP/OpenACC/Fortran] Fix mapping of optional (present|absent) arguments

Browse Source 
2019-12-06  Tobias Burnus  <tobias@codesourcery.com>
            Kwok Cheung Yeung <kcy@codesourcery.com>

        gcc/fortran/
        * trans-openmp.c (gfc_build_conditional_assign,
        gfc_build_conditional_assign_expr): New static functions.
        (gfc_omp_finish_clause, gfc_trans_omp_clauses): Handle mapping of
        absent optional arguments and fix mapping of present optional args.

        gcc/
        * omp-low.c (lower_omp_target): For optional arguments, deref once
        more to obtain the type.

        libgomp/
        * oacc-mem.c (update_dev_host, gomp_acc_insert_pointer): Just return
        if input it a NULL pointer.
        * testsuite/libgomp.oacc-c-c++-common/lib-43.c: Remove; dependent on
        diagnostic of NULL pointer.
        * testsuite/libgomp.oacc-c-c++-common/lib-47.c: Ditto.
        * testsuite/libgomp.fortran/optional-map.f90: New.
        * testsuite/libgomp.fortran/use_device_addr-1.f90
        (test_dummy_opt_callee_1_absent): New.
        (test_dummy_opt_call_1): Call it.
        * testsuite/libgomp.fortran/use_device_addr-2.f90: Likewise.
        * testsuite/libgomp.fortran/use_device_addr-3.f90: Likewise.
        * testsuite/libgomp.fortran/use_device_addr-4.f90: Likewise.
        * testsuite/libgomp.oacc-fortran/optional-cache.f95: New.
        * testsuite/libgomp.oacc-fortran/optional-data-copyin-by-value.f90: New.
        * testsuite/libgomp.oacc-fortran/optional-data-copyin.f90: New.
        * testsuite/libgomp.oacc-fortran/optional-data-copyout.f90: New.
        * testsuite/libgomp.oacc-fortran/optional-data-enter-exit.f90: New.
        * testsuite/libgomp.oacc-fortran/optional-declare.f90: New.
        * testsuite/libgomp.oacc-fortran/optional-firstprivate.f90: New.
        * testsuite/libgomp.oacc-fortran/optional-host_data.f90: New.
        * testsuite/libgomp.oacc-fortran/optional-nested-calls.f90: New.
        * testsuite/libgomp.oacc-fortran/optional-private.f90: New.
        * testsuite/libgomp.oacc-fortran/optional-reduction.f90: New.
        * testsuite/libgomp.oacc-fortran/optional-update-device.f90: New.
        * testsuite/libgomp.oacc-fortran/optional-update-host.f90: New.


Co-Authored-By: Kwok Cheung Yeung <kcy@codesourcery.com>

From-SVN: r279043
This commit is contained in:
Tobias Burnus 2019-12-06 13:06:53 +00:00 committed by Tobias Burnus
parent e150da3833
commit 6e4d01d61f
26 changed files with 1672 additions and 112 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
gcc/ChangeLog
View File

@ -1,3 +1,9 @@
2019-12-06 Tobias Burnus <tobias@codesourcery.com>
Kwok Cheung Yeung <kcy@codesourcery.com>
* omp-low.c (lower_omp_target): For optional arguments, deref once
more to obtain the type.
2019-12-06 Richard Biener <rguenther@suse.de>
* match.pd (nop_convert): Remove empty match. Use nop_convert?

8
gcc/fortran/ChangeLog
View File

@ -1,3 +1,11 @@
2019-12-06 Tobias Burnus <tobias@codesourcery.com>
Kwok Cheung Yeung <kcy@codesourcery.com>
* trans-openmp.c (gfc_build_conditional_assign,
gfc_build_conditional_assign_expr): New static functions.
(gfc_omp_finish_clause, gfc_trans_omp_clauses): Handle mapping of
absent optional arguments and fix mapping of present optional args.
2019-12-05 Tobias Burnus <tobias@codesourcery.com>
* trans-openmp.c (gfc_omp_is_optional_argument,

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

@ -1180,6 +1180,59 @@ gfc_omp_clause_dtor (tree clause, tree decl)
return tem;
}
/* Build a conditional expression in BLOCK. If COND_VAL is not
null, then the block THEN_B is executed, otherwise ELSE_VAL
is assigned to VAL. */
static void
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 val_ty = TREE_TYPE (val);
if (else_val)
{
gfc_init_block (&cond_block);
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));
}
/* Build a conditional expression in BLOCK, returning a temporary
variable containing the result. If COND_VAL is not null, then
THEN_VAL will be assigned to the variable, otherwise ELSE_VAL
is assigned.
*/
static tree
gfc_build_cond_assign_expr (stmtblock_t *block, tree cond_val,
tree then_val, tree else_val)
{
tree val;
tree val_ty = TREE_TYPE (then_val);
stmtblock_t cond_block;
val = create_tmp_var (val_ty);
gfc_init_block (&cond_block);
gfc_add_modify (&cond_block, val, then_val);
tree then_b = gfc_finish_block (&cond_block);
gfc_build_cond_assign (block, val, cond_val, then_b, else_val);
return val;
}
void
gfc_omp_finish_clause (tree c, gimple_seq *pre_p)
@ -1204,6 +1257,8 @@ 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);
if (POINTER_TYPE_P (TREE_TYPE (decl)))
{
if (!gfc_omp_privatize_by_reference (decl)
@ -1218,8 +1273,30 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p)
OMP_CLAUSE_DECL (c4) = decl;
OMP_CLAUSE_SIZE (c4) = size_int (0);
decl = build_fold_indirect_ref (decl);
OMP_CLAUSE_DECL (c) = decl;
OMP_CLAUSE_SIZE (c) = NULL_TREE;
if (present
&& (GFC_DECL_GET_SCALAR_POINTER (orig_decl)
|| GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl)))
{
c2 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_POINTER);
OMP_CLAUSE_DECL (c2) = decl;
OMP_CLAUSE_SIZE (c2) = size_int (0);
stmtblock_t block;
gfc_start_block (&block);
tree ptr = decl;
ptr = gfc_build_cond_assign_expr (&block, present, decl,
null_pointer_node);
gimplify_and_add (gfc_finish_block (&block), pre_p);
ptr = build_fold_indirect_ref (ptr);
OMP_CLAUSE_DECL (c) = ptr;
OMP_CLAUSE_SIZE (c) = TYPE_SIZE_UNIT (TREE_TYPE (ptr));
}
else
{
OMP_CLAUSE_DECL (c) = decl;
OMP_CLAUSE_SIZE (c) = NULL_TREE;
}
if (TREE_CODE (TREE_TYPE (orig_decl)) == REFERENCE_TYPE
&& (GFC_DECL_GET_SCALAR_POINTER (orig_decl)
|| GFC_DECL_GET_SCALAR_ALLOCATABLE (orig_decl)))
@ -1238,16 +1315,38 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p)
gfc_start_block (&block);
tree type = TREE_TYPE (decl);
tree ptr = gfc_conv_descriptor_data_get (decl);
if (present)
ptr = gfc_build_cond_assign_expr (&block, present, ptr,
null_pointer_node);
ptr = fold_convert (build_pointer_type (char_type_node), ptr);
ptr = build_fold_indirect_ref (ptr);
OMP_CLAUSE_DECL (c) = ptr;
c2 = build_omp_clause (input_location, OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (c2, GOMP_MAP_TO_PSET);
OMP_CLAUSE_DECL (c2) = decl;
if (present)
{
ptr = create_tmp_var (TREE_TYPE (TREE_OPERAND (decl, 0)));
gfc_add_modify (&block, ptr, TREE_OPERAND (decl, 0));
OMP_CLAUSE_DECL (c2) = build_fold_indirect_ref (ptr);
}
else
OMP_CLAUSE_DECL (c2) = decl;
OMP_CLAUSE_SIZE (c2) = TYPE_SIZE_UNIT (type);
c3 = build_omp_clause (OMP_CLAUSE_LOCATION (c), OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (c3, GOMP_MAP_POINTER);
OMP_CLAUSE_DECL (c3) = gfc_conv_descriptor_data_get (decl);
if (present)
{
ptr = gfc_conv_descriptor_data_get (decl);
ptr = gfc_build_addr_expr (NULL, ptr);
ptr = gfc_build_cond_assign_expr (&block, present,
ptr, null_pointer_node);
ptr = build_fold_indirect_ref (ptr);
OMP_CLAUSE_DECL (c3) = ptr;
}
else
OMP_CLAUSE_DECL (c3) = gfc_conv_descriptor_data_get (decl);
OMP_CLAUSE_SIZE (c3) = size_int (0);
tree size = create_tmp_var (gfc_array_index_type);
tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type));
@ -1273,11 +1372,35 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p)
tem = gfc_conv_descriptor_data_get (decl);
tem = fold_convert (pvoid_type_node, tem);
cond = fold_build2_loc (input_location, NE_EXPR,
logical_type_node, tem, null_pointer_node);
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);
}
gfc_add_expr_to_block (&block, build3_loc (input_location, COND_EXPR,
void_type_node, cond,
then_b, else_b));
}
else if (present)
{
stmtblock_t cond_block;
tree then_b;
gfc_init_block (&cond_block);
gfc_add_modify (&cond_block, size,
gfc_full_array_size (&cond_block, decl,
GFC_TYPE_ARRAY_RANK (type)));
gfc_add_modify (&cond_block, size,
fold_build2 (MULT_EXPR, gfc_array_index_type,
size, elemsz));
then_b = gfc_finish_block (&cond_block);
gfc_build_cond_assign (&block, size, present, then_b,
build_int_cst (gfc_array_index_type, 0));
}
else
{
gfc_add_modify (&block, size,
@ -2257,6 +2380,9 @@ 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);
if (POINTER_TYPE_P (TREE_TYPE (decl))
&& (gfc_omp_privatize_by_reference (decl)
|| GFC_DECL_GET_SCALAR_POINTER (decl)
@ -2289,6 +2415,9 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
{
tree type = TREE_TYPE (decl);
tree ptr = gfc_conv_descriptor_data_get (decl);
if (present)
ptr = gfc_build_cond_assign_expr (block, present, ptr,
null_pointer_node);
ptr = fold_convert (build_pointer_type (char_type_node),
ptr);
ptr = build_fold_indirect_ref (ptr);
@ -2301,8 +2430,18 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
node3 = build_omp_clause (input_location,
OMP_CLAUSE_MAP);
OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_POINTER);
OMP_CLAUSE_DECL (node3)
= gfc_conv_descriptor_data_get (decl);
if (present)
{
ptr = gfc_conv_descriptor_data_get (decl);
ptr = gfc_build_addr_expr (NULL, ptr);
ptr = gfc_build_cond_assign_expr (block, present, ptr,
null_pointer_node);
ptr = build_fold_indirect_ref (ptr);
OMP_CLAUSE_DECL (node3) = ptr;
}
else
OMP_CLAUSE_DECL (node3)
= gfc_conv_descriptor_data_get (decl);
OMP_CLAUSE_SIZE (node3) = size_int (0);
/* We have to check for n->sym->attr.dimension because
@ -2327,8 +2466,20 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
tem = gfc_conv_descriptor_data_get (decl);
tem = fold_convert (pvoid_type_node, tem);
cond = fold_build2_loc (input_location, NE_EXPR,
logical_type_node,
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);
}
gfc_add_expr_to_block (block,
build3_loc (input_location,
COND_EXPR,
@ -2338,9 +2489,34 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
OMP_CLAUSE_SIZE (node) = size;
}
else if (n->sym->attr.dimension)
OMP_CLAUSE_SIZE (node)
= gfc_full_array_size (block, decl,
GFC_TYPE_ARRAY_RANK (type));
{
stmtblock_t cond_block;
gfc_init_block (&cond_block);
tree size = gfc_full_array_size (&cond_block, decl,
GFC_TYPE_ARRAY_RANK (type));
if (present)
{
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);
gfc_add_expr_to_block (block, cond);
OMP_CLAUSE_SIZE (node) = var;
}
else
{
gfc_add_block_to_block (block, &cond_block);
OMP_CLAUSE_SIZE (node) = size;
}
}
if (n->sym->attr.dimension)
{
tree elemsz
@ -2351,6 +2527,18 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
OMP_CLAUSE_SIZE (node), elemsz);
}
}
else if (present
&& TREE_CODE (decl) == INDIRECT_REF
&& (TREE_CODE (TREE_OPERAND (decl, 0))
== INDIRECT_REF))
{
/* A single indirectref is handled by the middle end. */
gcc_assert (!POINTER_TYPE_P (TREE_TYPE (decl)));
decl = TREE_OPERAND (decl, 0);
decl = gfc_build_cond_assign_expr (block, present, decl,
null_pointer_node);
OMP_CLAUSE_DECL (node) = build_fold_indirect_ref (decl);
}
else
OMP_CLAUSE_DECL (node) = decl;
}

3
gcc/omp-low.c
View File

@ -11817,7 +11817,8 @@ lower_omp_target (gimple_stmt_iterator *gsi_p, omp_context *ctx)
{
gcc_checking_assert (is_gimple_omp_oacc (ctx->stmt));
s = TREE_TYPE (ovar);
if (TREE_CODE (s) == REFERENCE_TYPE)
if (TREE_CODE (s) == REFERENCE_TYPE
|| omp_check_optional_argument (ovar, false))
s = TREE_TYPE (s);
s = TYPE_SIZE_UNIT (s);
}

29
libgomp/ChangeLog
View File

@ -1,3 +1,32 @@
2019-12-06 Tobias Burnus <tobias@codesourcery.com>
Kwok Cheung Yeung <kcy@codesourcery.com>
* oacc-mem.c (update_dev_host, gomp_acc_insert_pointer): Just return
if input it a NULL pointer.
* testsuite/libgomp.oacc-c-c++-common/lib-43.c: Remove; dependent on
diagnostic of NULL pointer.
* testsuite/libgomp.oacc-c-c++-common/lib-47.c: Ditto.
* testsuite/libgomp.fortran/optional-map.f90: New.
* testsuite/libgomp.fortran/use_device_addr-1.f90
(test_dummy_opt_callee_1_absent): New.
(test_dummy_opt_call_1): Call it.
* testsuite/libgomp.fortran/use_device_addr-2.f90: Likewise.
* testsuite/libgomp.fortran/use_device_addr-3.f90: Likewise.
* testsuite/libgomp.fortran/use_device_addr-4.f90: Likewise.
* testsuite/libgomp.oacc-fortran/optional-cache.f95: New.
* testsuite/libgomp.oacc-fortran/optional-data-copyin-by-value.f90: New.
* testsuite/libgomp.oacc-fortran/optional-data-copyin.f90: New.
* testsuite/libgomp.oacc-fortran/optional-data-copyout.f90: New.
* testsuite/libgomp.oacc-fortran/optional-data-enter-exit.f90: New.
* testsuite/libgomp.oacc-fortran/optional-declare.f90: New.
* testsuite/libgomp.oacc-fortran/optional-firstprivate.f90: New.
* testsuite/libgomp.oacc-fortran/optional-host_data.f90: New.
* testsuite/libgomp.oacc-fortran/optional-nested-calls.f90: New.
* testsuite/libgomp.oacc-fortran/optional-private.f90: New.
* testsuite/libgomp.oacc-fortran/optional-reduction.f90: New.
* testsuite/libgomp.oacc-fortran/optional-update-device.f90: New.
* testsuite/libgomp.oacc-fortran/optional-update-host.f90: New.
2019-12-05 Tobias Burnus <tobias@codesourcery.com>
* testsuite/libgomp.oacc-fortran/error_stop-1.f: Also don't

9
libgomp/oacc-mem.c
View File

@ -829,6 +829,12 @@ update_dev_host (int is_dev, void *h, size_t s, int async)
if (acc_dev->capabilities & GOMP_OFFLOAD_CAP_SHARED_MEM)
return;
/* Fortran optional arguments that are non-present result in a
NULL host address here. This can safely be ignored as it is
not possible to 'update' a non-present optional argument. */
if (h == NULL)
return;
acc_prof_info prof_info;
acc_api_info api_info;
bool profiling_p = GOACC_PROFILING_SETUP_P (thr, &prof_info, &api_info);
@ -899,6 +905,9 @@ gomp_acc_insert_pointer (size_t mapnum, void **hostaddrs, size_t *sizes,
struct goacc_thread *thr = goacc_thread ();
struct gomp_device_descr *acc_dev = thr->dev;
if (*hostaddrs == NULL)
return;
if (acc_is_present (*hostaddrs, *sizes))
{
splay_tree_key n;

121
libgomp/testsuite/libgomp.fortran/optional-map.f90 Normal file
View File

@ -0,0 +1,121 @@
! { dg-do run }
!
implicit none (type, external)
call sub()
call sub2()
call call_present_1()
call call_present_2()
contains
subroutine call_present_1()
integer :: ii, ival, iarr, iptr, iparr
pointer :: iptr, iparr
dimension :: iarr(2), iparr(:)
allocate(iptr,iparr(2))
ii = 101
ival = 102
iptr = 103
iarr = 104
iparr = 105
call sub_present(ii, ival, iarr, iptr, iparr)
deallocate(iptr,iparr)
end subroutine
subroutine call_present_2()
integer :: ii, ival, iarr, iptr, iparr
pointer :: iptr, iparr
dimension :: iarr(2), iparr(:)
allocate(iptr,iparr(2))
ii = 201
ival = 202
iptr = 203
iarr = 204
iparr = 205
call sub2_present(ii, ival, iarr, iptr, iparr)
deallocate(iptr,iparr)
end subroutine
subroutine sub(ii, ival, iarr, iptr, iparr)
integer, optional :: ii, ival, iarr, iptr, iparr
pointer :: iptr, iparr
dimension :: iarr(:), iparr(:)
value :: ival
integer :: err
err = 42
!$omp target map(ii, ival, iarr, iptr, iparr, err)
if (present(ii)) then
ii = iptr + ival
iarr = iparr
else
err = 0
end if
if (present(ii)) err = 1
if (present(ival)) err = 2
if (present(iarr)) err = 3
if (present(iptr)) err = 4
if (present(iparr)) err = 5
!$omp end target
if (err /= 0) stop 1
end subroutine sub
subroutine sub2(ii, ival, iarr, iptr, iparr)
integer, optional :: ii, ival, iarr, iptr, iparr
pointer :: iptr, iparr
dimension :: iarr(:), iparr(:)
value :: ival
integer :: err(1) ! otherwise, implied defaultmap is firstprivate
err(1) = 42
!$omp target ! automatic mapping with implied defaultmap(tofrom)
if (present(ii)) then
ii = iptr + ival
iarr = iparr
else
err(1) = 0
end if
if (present(ii)) err(1) = 1
if (present(ival)) err(1) = 2
if (present(iarr)) err(1) = 3
if (present(iptr)) err(1) = 4
if (present(iparr)) err(1) = 5
!$omp end target
if (err(1) /= 0) stop 2
end subroutine sub2
subroutine sub_present(ii, ival, iarr, iptr, iparr)
integer, optional :: ii, ival, iarr, iptr, iparr
pointer :: iptr, iparr
dimension :: iarr(:), iparr(:)
value :: ival
integer :: err
err = 42
!$omp target map(ii, ival, iarr, iptr, iparr, err)
if (.not.present(ii)) err = 1
if (.not.present(ival)) err = 2
if (.not.present(iarr)) err = 3
if (.not.present(iptr)) err = 4
if (.not.present(iparr)) err = 5
err = err - 42 - 101-102-103-104-105 + ii+ival+iarr(2)+iptr+iparr(2)
!$omp end target
if (err /= 0) stop 3
end subroutine sub_present
subroutine sub2_present(ii, ival, iarr, iptr, iparr)
integer, optional :: ii, ival, iarr, iptr, iparr
pointer :: iptr, iparr
dimension :: iarr(:), iparr(:)
value :: ival
integer :: err(1) ! otherwise, implied defaultmap is firstprivate
err(1) = 53
!$omp target ! automatic mapping with implied defaultmap(tofrom)
! Note: OpenMP 4.5's 'defaultmap' is not yet supported, PR 92568
if (.not.present(ii)) err = 1
if (.not.present(ival)) err = 2
if (.not.present(iarr)) err = 3
if (.not.present(iptr)) err = 4
if (.not.present(iparr)) err = 5
err = err - 53 - 201-202-203-204-205 + ii+ival+iarr(2)+iptr+iparr(2)
!$omp end target
if (err(1) /= 0) stop 4
end subroutine sub2_present
end

36
libgomp/testsuite/libgomp.fortran/use_device_addr-1.f90
View File

@ -472,6 +472,7 @@ contains
hh = 88.0_c_double
call test_dummy_opt_callee_1(aa, bb, cc, dd, ee, ff, gg, hh, N)
call test_dummy_opt_callee_1_absent(N=N)
deallocate(ee, ff) ! pointers, only
end subroutine test_dummy_opt_call_1
@ -527,6 +528,41 @@ contains
if (any(abs(3.0_c_double * gg - hh) > 10.0_c_double * epsilon(gg))) stop 72
end subroutine test_dummy_opt_callee_1
subroutine test_dummy_opt_callee_1_absent(aa, bb, cc, dd, ee, ff, gg, hh, N)
! scalars
real(c_double), optional, target :: aa, bb
real(c_double), optional, target, allocatable :: cc, dd
real(c_double), optional, pointer :: ee, ff
! non-descriptor arrays
real(c_double), optional, target :: gg(N), hh(N)
integer, value :: N
integer :: err
! All shall be absent
if (present(aa) .or. present(bb)) stop 243
if (present(cc) .or. present(dd)) stop 244
if (present(ee) .or. present(ff)) stop 245
if (present(gg) .or. present(hh)) stop 246
!$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
if (present(aa) .or. present(bb)) stop 247
!$omp end target data
!$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
if (present(cc) .or. present(dd)) stop 248
!$omp end target data
!$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
if (present(ee) .or. present(ff)) stop 249
!$omp end target data
!$omp target data map(to:gg) map(from:hh) use_device_addr(gg,hh)
if (present(gg) .or. present(hh)) stop 250
!$omp end target data
end subroutine test_dummy_opt_callee_1_absent
! Save device ptr - and recall pointer
subroutine test_dummy_opt_call_2()
integer, parameter :: N = 1000

36
libgomp/testsuite/libgomp.fortran/use_device_addr-2.f90
View File

@ -472,6 +472,7 @@ contains
hh = 88.0_c_float
call test_dummy_opt_callee_1(aa, bb, cc, dd, ee, ff, gg, hh, N)
call test_dummy_opt_callee_1_absent(N=N)
deallocate(ee, ff) ! pointers, only
end subroutine test_dummy_opt_call_1
@ -527,6 +528,41 @@ contains
if (any(abs(3.0_c_float * gg - hh) > 10.0_c_float * epsilon(gg))) stop 72
end subroutine test_dummy_opt_callee_1
subroutine test_dummy_opt_callee_1_absent(aa, bb, cc, dd, ee, ff, gg, hh, N)
! scalars
real(c_float), optional, target :: aa, bb
real(c_float), optional, target, allocatable :: cc, dd
real(c_float), optional, pointer :: ee, ff
! non-descriptor arrays
real(c_float), optional, target :: gg(N), hh(N)
integer, value :: N
integer :: err
! All shall be absent
if (present(aa) .or. present(bb)) stop 243
if (present(cc) .or. present(dd)) stop 244
if (present(ee) .or. present(ff)) stop 245
if (present(gg) .or. present(hh)) stop 246
!$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
if (present(aa) .or. present(bb)) stop 247
!$omp end target data
!$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
if (present(cc) .or. present(dd)) stop 248
!$omp end target data
!$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
if (present(ee) .or. present(ff)) stop 249
!$omp end target data
!$omp target data map(to:gg) map(from:hh) use_device_addr(gg,hh)
if (present(gg) .or. present(hh)) stop 250
!$omp end target data
end subroutine test_dummy_opt_callee_1_absent
! Save device ptr - and recall pointer
subroutine test_dummy_opt_call_2()
integer, parameter :: N = 1000

27
libgomp/testsuite/libgomp.fortran/use_device_addr-3.f90
View File

@ -290,6 +290,7 @@ contains
ff = 66.0_c_double
call test_dummy_opt_callee_1(aa, bb, cc, dd, ee, ff, N)
call test_dummy_opt_callee_1_absent(N=N)
deallocate(ee, ff) ! pointers, only
end subroutine test_dummy_opt_call_1
@ -336,6 +337,32 @@ contains
if (any(abs(3.0_c_double * ee - ff) > 10.0_c_double * epsilon(ee))) stop 1
end subroutine test_dummy_opt_callee_1
subroutine test_dummy_opt_callee_1_absent(aa, bb, cc, dd, ee, ff, N)
! scalars
real(c_double), optional, target :: aa(:), bb(:)
real(c_double), optional, target, allocatable :: cc(:), dd(:)
real(c_double), optional, pointer :: ee(:), ff(:)
integer, value :: N
! All shall be absent
if (present(aa) .or. present(bb)) stop 1
if (present(cc) .or. present(dd)) stop 1
if (present(ee) .or. present(ff)) stop 1
!$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
if (present(aa) .or. present(bb)) stop 1
!$omp end target data
!$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
if (present(cc) .or. present(dd)) stop 1
!$omp end target data
!$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
if (present(ee) .or. present(ff)) stop 1
!$omp end target data
end subroutine test_dummy_opt_callee_1_absent
! Save device ptr - and recall pointer
subroutine test_dummy_opt_call_2()
integer, parameter :: N = 1000

27
libgomp/testsuite/libgomp.fortran/use_device_addr-4.f90
View File

@ -290,6 +290,7 @@ contains
ff = 66.0_c_float
call test_dummy_opt_callee_1(aa, bb, cc, dd, ee, ff, N)
call test_dummy_opt_callee_1_absent(N=N)
deallocate(ee, ff) ! pointers, only
end subroutine test_dummy_opt_call_1
@ -336,6 +337,32 @@ contains
if (any(abs(3.0_c_float * ee - ff) > 10.0_c_float * epsilon(ee))) stop 1
end subroutine test_dummy_opt_callee_1
subroutine test_dummy_opt_callee_1_absent(aa, bb, cc, dd, ee, ff, N)
! scalars
real(c_float), optional, target :: aa(:), bb(:)
real(c_float), optional, target, allocatable :: cc(:), dd(:)
real(c_float), optional, pointer :: ee(:), ff(:)
integer, value :: N
! All shall be absent
if (present(aa) .or. present(bb)) stop 1
if (present(cc) .or. present(dd)) stop 1
if (present(ee) .or. present(ff)) stop 1
!$omp target data map(to:aa) map(from:bb) use_device_addr(aa,bb)
if (present(aa) .or. present(bb)) stop 1
!$omp end target data
!$omp target data map(to:cc) map(from:dd) use_device_addr(cc,dd)
if (present(cc) .or. present(dd)) stop 1
!$omp end target data
!$omp target data map(to:ee) map(from:ff) use_device_addr(ee,ff)
if (present(ee) .or. present(ff)) stop 1
!$omp end target data
end subroutine test_dummy_opt_callee_1_absent
! Save device ptr - and recall pointer
subroutine test_dummy_opt_call_2()
integer, parameter :: N = 1000

51
libgomp/testsuite/libgomp.oacc-c-c++-common/lib-43.c
View File

@ -1,51 +0,0 @@
/* Exercise acc_update_device with a NULL data address on nvidia targets. */
/* { dg-do run { target openacc_nvidia_accel_selected } } */
#include <stdio.h>
#include <stdlib.h>
#include <openacc.h>
int
main (int argc, char **argv)
{
const int N = 256;
int i;
unsigned char *h;
void *d;
h = (unsigned char *) malloc (N);
for (i = 0; i < N; i++)
{
h[i] = i;
}
d = acc_copyin (h, N);
if (!d)
abort ();
for (i = 0; i < N; i++)
{
h[i] = 0xab;
}
fprintf (stderr, "CheCKpOInT\n");
acc_update_device (0, N);
acc_copyout (h, N);
for (i = 0; i < N; i++)
{
if (h[i] != 0xab)
abort ();
}
free (h);
return 0;
}
/* { dg-output "CheCKpOInT(\n|\r\n|\r).*" } */
/* { dg-output "\\\[\[^\n\r]*,256\\\] is not mapped" } */
/* { dg-shouldfail "" } */

49
libgomp/testsuite/libgomp.oacc-c-c++-common/lib-47.c
View File

@ -1,49 +0,0 @@
/* Exercise acc_update_self with a NULL data mapping on nvidia targets. */
/* { dg-do run { target openacc_nvidia_accel_selected } } */
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#include <openacc.h>
int
main (int argc, char **argv)
{
const int N = 256;
int i;
unsigned char *h;
void *d;
h = (unsigned char *) malloc (N);
for (i = 0; i < N; i++)
{
h[i] = i;
}
d = acc_copyin (h, N);
if (!d)
abort ();
memset (&h[0], 0, N);
fprintf (stderr, "CheCKpOInT\n");
acc_update_self (0, N);
for (i = 0; i < N; i++)
{
if (h[i] != i)
abort ();
}
acc_delete (h, N);
free (h);
return 0;
}
/* { dg-output "CheCKpOInT(\n|\r\n|\r).*" } */
/* { dg-output "\\\[\[^\n\r]*,256\\\] is not mapped" } */
/* { dg-shouldfail "" } */

23
libgomp/testsuite/libgomp.oacc-fortran/optional-cache.f95 Normal file
View File

@ -0,0 +1,23 @@
! Test that the cache directives work with optional arguments. The effect
! of giving a non-present argument to the cache directive is not tested as
! it is undefined. The test is based on gfortran.dg/goacc/cache-1.f95.
! { dg-additional-options "-std=f2008" }
program cache_test
implicit none
integer :: d(10), e(7,13)
call do_test(d, e)
contains
subroutine do_test(d, e)
integer, optional :: d(10), e(7,13)
integer :: i
do concurrent (i=1:5)
!$acc cache (d(1:3))
!$acc cache (d(i:i+2))
!$acc cache (e(1:3,2:4))
!$acc cache (e(i:i+2,i+1:i+3))
enddo
end
end

29
libgomp/testsuite/libgomp.oacc-fortran/optional-data-copyin-by-value.f90 Normal file
View File

@ -0,0 +1,29 @@
! Test OpenACC data regions with optional arguments passed by value.
! { dg-do run }
program test
implicit none
integer :: res
if (foo(27) .ne. 27) stop 1
if (foo(16, 18) .ne. 288) stop 1
contains
function foo(x, y)
integer, value :: x
integer, value, optional :: y
integer :: res, foo
!$acc data copyin(x, y) copyout(res)
!$acc parallel
res = x
if (present(y)) then
res = res * y
end if
!$acc end parallel
!$acc end data
foo = res
end function foo
end program test

140
libgomp/testsuite/libgomp.oacc-fortran/optional-data-copyin.f90 Normal file
View File

@ -0,0 +1,140 @@
! Test OpenACC data regions with a copy-in of optional arguments.
! { dg-do run }
program test
implicit none
integer, parameter :: n = 64
integer :: i
integer :: a_int, b_int, c_int, res_int
integer :: a_arr(n), b_arr(n), c_arr(n), res_arr(n)
integer, allocatable :: a_alloc(:), b_alloc(:), c_alloc(:), res_alloc(:)
a_int = 7
b_int = 3
c_int = 11
call test_int(res_int, a_int)
if (res_int .ne. a_int) stop 1
call test_int(res_int, a_int, b_int)
if (res_int .ne. a_int * b_int) stop 2
call test_int(res_int, a_int, b_int, c_int)
if (res_int .ne. a_int * b_int + c_int) stop 3
do i = 1, n
a_arr(i) = i
b_arr(i) = n - i + 1
c_arr(i) = i * 3
end do
call test_array(res_arr, a_arr)
do i = 1, n
if (res_arr(i) .ne. a_arr(i)) stop 4
end do
call test_array(res_arr, a_arr, b_arr)
do i = 1, n
if (res_arr(i) .ne. a_arr(i) * b_arr(i)) stop 5
end do
call test_array(res_arr, a_arr, b_arr, c_arr)
do i = 1, n
if (res_arr(i) .ne. a_arr(i) * b_arr(i) + c_arr(i)) stop 6
end do
allocate (a_alloc(n))
allocate (b_alloc(n))
allocate (c_alloc(n))
allocate (res_alloc(n))
do i = 1, n
a_alloc(i) = i
b_alloc(i) = n - i + 1
c_alloc(i) = i * 3
end do
call test_allocatable(res_alloc, a_alloc)
do i = 1, n
if (res_alloc(i) .ne. a_alloc(i)) stop 7
end do
call test_allocatable(res_alloc, a_alloc, b_alloc)
do i = 1, n
if (res_alloc(i) .ne. a_alloc(i) * b_alloc(i)) stop 8
end do
call test_allocatable(res_alloc, a_alloc, b_alloc, c_alloc)
do i = 1, n
if (res_alloc(i) .ne. a_alloc(i) * b_alloc(i) + c_alloc(i)) stop 9
end do
deallocate (a_alloc)
deallocate (b_alloc)
deallocate (c_alloc)
deallocate (res_alloc)
contains
subroutine test_int(res, a, b, c)
integer :: res
integer :: a
integer, optional :: b, c
!$acc data copyin(a, b, c) copyout(res)
!$acc parallel
res = a
if (present(b)) res = res * b
if (present(c)) res = res + c
!$acc end parallel
!$acc end data
end subroutine test_int
subroutine test_array(res, a, b, c)
integer :: res(n)
integer :: a(n)
integer, optional :: b(n), c(n)
!$acc data copyin(a, b, c) copyout(res)
!$acc parallel loop
do i = 1, n
res(i) = a(i)
end do
!$acc parallel loop
do i = 1, n
if (present(b)) res(i) = res(i) * b(i)
end do
!$acc parallel loop
do i = 1, n
if (present(c)) res(i) = res(i) + c(i)
end do
!$acc end data
end subroutine test_array
subroutine test_allocatable(res, a, b, c)
integer, allocatable :: res(:)
integer, allocatable :: a(:)
integer, allocatable, optional :: b(:), c(:)
!$acc data copyin(a, b, c) copyout(res)
!$acc parallel loop
do i = 1, n
res(i) = a(i)
end do
!$acc parallel loop
do i = 1, n
if (present(b)) res(i) = res(i) * b(i)
end do
!$acc parallel loop
do i = 1, n
if (present(c)) res(i) = res(i) + c(i)
end do
!$acc end data
end subroutine test_allocatable
end program test

96
libgomp/testsuite/libgomp.oacc-fortran/optional-data-copyout.f90 Normal file
View File

@ -0,0 +1,96 @@
! Test OpenACC data regions with a copy-out of optional arguments.
! { dg-do run }
program test
implicit none
integer, parameter :: n = 64
integer :: i
integer :: a_int, b_int, res_int
integer :: a_arr(n), b_arr(n), res_arr(n)
integer, allocatable :: a_alloc(:), b_alloc(:), res_alloc(:)
res_int = 0
call test_int(a_int, b_int)
if (res_int .ne. 0) stop 1
call test_int(a_int, b_int, res_int)
if (res_int .ne. a_int * b_int) stop 2
res_arr(:) = 0
do i = 1, n
a_arr(i) = i
b_arr(i) = n - i + 1
end do
call test_array(a_arr, b_arr)
do i = 1, n
if (res_arr(i) .ne. 0) stop 3
end do
call test_array(a_arr, b_arr, res_arr)
do i = 1, n
if (res_arr(i) .ne. a_arr(i) * b_arr(i)) stop 4
end do
allocate (a_alloc(n))
allocate (b_alloc(n))
allocate (res_alloc(n))
res_alloc(:) = 0
do i = 1, n
a_alloc(i) = i
b_alloc(i) = n - i + 1
end do
call test_allocatable(a_alloc, b_alloc)
do i = 1, n
if (res_alloc(i) .ne. 0) stop 5
end do
call test_allocatable(a_alloc, b_alloc, res_alloc)
do i = 1, n
if (res_alloc(i) .ne. a_alloc(i) * b_alloc(i)) stop 6
end do
deallocate (a_alloc)
deallocate (b_alloc)
deallocate (res_alloc)
contains
subroutine test_int(a, b, res)
integer :: a, b
integer, optional :: res
!$acc data copyin(a, b) copyout(res)
!$acc parallel
if (present(res)) res = a * b
!$acc end parallel
!$acc end data
end subroutine test_int
subroutine test_array(a, b, res)
integer :: a(n), b(n)
integer, optional :: res(n)
!$acc data copyin(a, b) copyout(res)
!$acc parallel loop
do i = 1, n
if (present(res)) res(i) = a(i) * b(i)
end do
!$acc end data
end subroutine test_array
subroutine test_allocatable(a, b, res)
integer, allocatable :: a(:), b(:)
integer, allocatable, optional :: res(:)
!$acc data copyin(a, b) copyout(res)
!$acc parallel loop
do i = 1, n
if (present(res)) res(i) = a(i) * b(i)
end do
!$acc end data
end subroutine test_allocatable
end program test

91
libgomp/testsuite/libgomp.oacc-fortran/optional-data-enter-exit.f90 Normal file
View File

@ -0,0 +1,91 @@
! Test OpenACC unstructured enter data/exit data regions with optional
! arguments.
! { dg-do run }
program test
implicit none
integer, parameter :: n = 64
integer :: a(n), b(n), c(n), res(n)
integer :: x, y, z, r, i
do i = 1, n
a(i) = i
b(i) = n - i + 1
c(i) = i * 3
end do
res = test_array(a)
do i = 1, n
if (res(i) .ne. a(i)) stop 1
end do
res = test_array(a, b)
do i = 1, n
if (res(i) .ne. a(i) * b(i)) stop 2
end do
res = test_array(a, b, c)
do i = 1, n
if (res(i) .ne. a(i) * b(i) + c(i)) stop 3
end do
x = 7
y = 3
z = 11
r = test_int(x)
if (r .ne. x) stop 4
r = test_int(x, y)
if (r .ne. x * y) stop 5
r = test_int(x, y, z)
if (r .ne. x * y + z) stop 6
contains
function test_array(a, b, c)
integer :: a(n)
integer, optional :: b(n), c(n)
integer :: test_array(n), res(n)
!$acc enter data copyin(a, b, c) create(res)
!$acc parallel loop
do i = 1, n
res(i) = a(i)
end do
!$acc parallel loop
do i = 1, n
if (present(b)) then
res(i) = res(i) * b(i)
end if
end do
!$acc parallel loop
do i = 1, n
if (present(c)) then
res(i) = res(i) + c(i)
end if
end do
!$acc exit data copyout(res) delete(a, b, c)
test_array = res
end function test_array
function test_int(a, b, c)
integer :: a
integer, optional :: b, c
integer :: test_int, res
!$acc enter data copyin(a, b, c) create(res)
!$acc parallel present(a, b, c, res)
res = a
if (present(b)) res = res * b
if (present(c)) res = res + c
!$acc end parallel
!$acc exit data copyout(res) delete(a, b, c)
test_int = res
end function test_int
end program test

87
libgomp/testsuite/libgomp.oacc-fortran/optional-declare.f90 Normal file
View File

@ -0,0 +1,87 @@
! Test OpenACC declare directives with optional arguments.
! { dg-do run }
program test
implicit none
integer, parameter :: n = 64
integer :: i
integer :: a_int, b_int, c_int, res_int
integer :: a_arr(n), b_arr(n), c_arr(n), res_arr(n)
a_int = 7
b_int = 3
c_int = 11
call test_int(res_int, a_int)
if (res_int .ne. a_int) stop 1
call test_int(res_int, a_int, b_int)
if (res_int .ne. a_int * b_int) stop 2
call test_int(res_int, a_int, b_int, c_int)
if (res_int .ne. a_int * b_int + c_int) stop 3
do i = 1, n
a_arr(i) = i
b_arr(i) = n - i + 1
c_arr(i) = i * 3
end do
call test_array(res_arr, a_arr)
do i = 1, n
if (res_arr(i) .ne. a_arr(i)) stop 4
end do
call test_array(res_arr, a_arr, b_arr)
do i = 1, n
if (res_arr(i) .ne. a_arr(i) * b_arr(i)) stop 5
end do
call test_array(res_arr, a_arr, b_arr, c_arr)
do i = 1, n
if (res_arr(i) .ne. a_arr(i) * b_arr(i) + c_arr(i)) stop 6
end do
contains
subroutine test_int(res, a, b, c)
integer :: a
integer, optional :: b, c
!$acc declare present_or_copyin(a, b, c)
integer :: res
!$acc declare present_or_copyout(res)
!$acc parallel
res = a
if (present(b)) res = res * b
if (present(c)) res = res + c
!$acc end parallel
end subroutine test_int
subroutine test_array(res, a, b, c)
integer :: a(n)
integer, optional :: b(n), c(n)
!$acc declare present_or_copyin(a, b, c)
integer :: res(n)
!$acc declare present_or_copyout(res)
!$acc parallel loop
do i = 1, n
res(i) = a(i)
end do
!$acc parallel loop
do i = 1, n
if (present(b)) then
res(i) = res(i) * b(i)
end if
end do
!$acc parallel loop
do i = 1, n
if (present(c)) then
res(i) = res(i) + c(i)
end if
end do
end subroutine test_array
end program test

112
libgomp/testsuite/libgomp.oacc-fortran/optional-firstprivate.f90 Normal file
View File

@ -0,0 +1,112 @@
! Test that optional arguments work in firstprivate clauses. The effect of
! non-present arguments in firstprivate clauses is undefined, and is not
! tested for.
! { dg-do run }
program test_firstprivate
implicit none
integer, parameter :: n = 64
integer :: i, j
integer :: a_int, b_int, c_int, res_int
integer :: a_arr(n), b_arr(n), c_arr(n), res_arr(n)
integer, allocatable :: a_alloc(:), b_alloc(:), c_alloc(:), res_alloc(:)
a_int = 14
b_int = 5
c_int = 12
call test_int(res_int, a_int, b_int, c_int)
if (res_int .ne. a_int * b_int + c_int) stop 1
do i = 1, n
a_arr(i) = i
b_arr(i) = n - i + 1
c_arr(i) = i * 3
end do
call test_array(res_arr, a_arr, b_arr, c_arr)
do i = 1, n
if (res_arr(i) .ne. a_arr(i) * b_arr(i) + c_arr(i)) stop 2
end do
allocate(a_alloc(n))
allocate(b_alloc(n))
allocate(c_alloc(n))
allocate(res_alloc(n))
do i = 1, n
a_arr(i) = i
b_arr(i) = n - i + 1
c_arr(i) = i * 3
end do
call test_allocatable(res_alloc, a_alloc, b_alloc, c_alloc)
do i = 1, n
if (res_alloc(i) .ne. a_alloc(i) * b_alloc(i) + c_alloc(i)) stop 2
end do
deallocate(a_alloc)
deallocate(b_alloc)
deallocate(c_alloc)
deallocate(res_alloc)
contains
subroutine test_int(res, a, b, c)
integer :: a
integer, optional :: b, c
integer :: res
!$acc parallel firstprivate(a, b, c) copyout(res)
res = a
if (present(b)) res = res * b
if (present(c)) res = res + c
!$acc end parallel
end subroutine test_int
subroutine test_array(res, a, b, c)
integer :: a(n)
integer, optional :: b(n), c(n)
integer :: res(n)
!$acc data copyin(a, b, c) copyout(res)
!$acc parallel loop firstprivate(a)
do i = 1, n
res(i) = a(i)
end do
!$acc parallel loop firstprivate(b)
do i = 1, n
if (present(b)) res(i) = res(i) * b(i)
end do
!$acc parallel loop firstprivate(c)
do i = 1, n
if (present(c)) res(i) = res(i) + c(i)
end do
!$acc end data
end subroutine test_array
subroutine test_allocatable(res, a, b, c)
integer, allocatable :: a(:)
integer, allocatable, optional :: b(:), c(:)
integer, allocatable :: res(:)
!$acc data copyin(a, b, c) copyout(res)
!$acc parallel loop firstprivate(a)
do i = 1, n
res(i) = a(i)
end do
!$acc parallel loop firstprivate(b)
do i = 1, n
if (present(b)) res(i) = res(i) * b(i)
end do
!$acc parallel loop firstprivate(c)
do i = 1, n
if (present(c)) res(i) = res(i) + c(i)
end do
!$acc end data
end subroutine test_allocatable
end program test_firstprivate

39
libgomp/testsuite/libgomp.oacc-fortran/optional-host_data.f90 Normal file
View File

@ -0,0 +1,39 @@
! Test the host_data construct with optional arguments.
! Based on host_data-1.f90.
! { dg-do run }
! { dg-additional-options "-cpp" }
program test
implicit none
integer, target :: i
integer, pointer :: ip, iph
! Assign the same targets
ip => i
iph => i
call foo(iph)
call foo(iph, ip)
contains
subroutine foo(iph, ip)
integer, pointer :: iph
integer, pointer, optional :: ip
!$acc data copyin(i)
!$acc host_data use_device(ip)
! Test how the pointers compare inside a host_data construct
if (present(ip)) then
#if ACC_MEM_SHARED
if (.not. associated(ip, iph)) STOP 1
#else
if (associated(ip, iph)) STOP 2
#endif
end if
!$acc end host_data
!$acc end data
end subroutine foo
end program test

135
libgomp/testsuite/libgomp.oacc-fortran/optional-nested-calls.f90 Normal file
View File

@ -0,0 +1,135 @@
! Test propagation of optional arguments from within an OpenACC parallel region.
! { dg-do run }
program test
implicit none
integer, parameter :: n = 64
integer :: i
integer :: res_int
integer :: a_arr(n), b_arr(n), res_arr(n)
integer, allocatable :: a_alloc(:), b_alloc(:), res_alloc(:)
call test_int_caller(res_int, 5)
if (res_int .ne. 10) stop 1
call test_int_caller(res_int, 2, 3)
if (res_int .ne. 11) stop 2
do i = 1, n
a_arr(i) = i
b_arr(i) = n - i + 1
end do
call test_array_caller(res_arr, a_arr)
do i = 1, n
if (res_arr(i) .ne. 2 * a_arr(i)) stop 3
end do
call test_array_caller(res_arr, a_arr, b_arr)
do i = 1, n
if (res_arr(i) .ne. a_arr(i) * b_arr(i) + a_arr(i) + b_arr(i)) stop 4
end do
allocate(a_alloc(n))
allocate(b_alloc(n))
allocate(res_alloc(n))
do i = 1, n
a_alloc(i) = i
b_alloc(i) = n - i + 1
end do
call test_array_caller(res_arr, a_arr)
do i = 1, n
if (res_arr(i) .ne. 2 * a_alloc(i)) stop 5
end do
call test_array_caller(res_arr, a_arr, b_arr)
do i = 1, n
if (res_arr(i) .ne. a_arr(i) * b_alloc(i) + a_alloc(i) + b_alloc(i)) stop 6
end do
deallocate(a_alloc)
deallocate(b_alloc)
deallocate(res_alloc)
contains
subroutine test_int_caller(res, a, b)
integer :: res, a
integer, optional :: b
!$acc data copyin(a, b) copyout (res)
!$acc parallel
res = a
if (present(b)) res = res * b
call test_int_callee(res, a, b)
!$acc end parallel
!$acc end data
end subroutine test_int_caller
subroutine test_int_callee(res, a, b)
!$acc routine seq
integer :: res, a
integer, optional :: b
res = res + a
if (present(b)) res = res + b
end subroutine test_int_callee
subroutine test_array_caller(res, a, b)
integer :: res(n), a(n), i
integer, optional :: b(n)
!$acc data copyin(a, b) copyout(res)
!$acc parallel
!$acc loop seq
do i = 1, n
res(i) = a(i)
if (present(b)) res(i) = res(i) * b(i)
end do
call test_array_callee(res, a, b)
!$acc end parallel
!$acc end data
end subroutine test_array_caller
subroutine test_array_callee(res, a, b)
!$acc routine seq
integer :: res(n), a(n), i
integer, optional :: b(n)
do i = 1, n
res(i) = res(i) + a(i)
if (present(b)) res(i) = res(i) + b(i)
end do
end subroutine test_array_callee
subroutine test_allocatable_caller(res, a, b)
integer :: i
integer, allocatable :: res(:), a(:)
integer, allocatable, optional :: b(:)
!$acc data copyin(a, b) copyout(res)
!$acc parallel
!$acc loop seq
do i = 1, n
res(i) = a(i)
if (present(b)) res(i) = res(i) * b(i)
end do
call test_array_callee(res, a, b)
!$acc end parallel
!$acc end data
end subroutine test_allocatable_caller
subroutine test_allocatable_callee(res, a, b)
!$acc routine seq
integer :: i
integer, allocatable :: res(:), a(:)
integer, allocatable, optional :: b(:)
do i = 1, n
res(i) = res(i) + a(i)
if (present(b)) res(i) = res(i) + b(i)
end do
end subroutine test_allocatable_callee
end program test

115
libgomp/testsuite/libgomp.oacc-fortran/optional-private.f90 Normal file
View File

@ -0,0 +1,115 @@
! Test that optional arguments work in private clauses. The effect of
! non-present arguments in private clauses is undefined, and is not tested
! for. The tests are based on those in private-variables.f90.
! { dg-do run }
program main
implicit none
type vec3
integer x, y, z, attr(13)
end type vec3
integer :: x
type(vec3) :: pt
integer :: arr(2)
call t1(x)
call t2(pt)
call t3(arr)
contains
! Test of gang-private variables declared on loop directive.
subroutine t1(x)
integer, optional :: x
integer :: i, arr(32)
do i = 1, 32
arr(i) = i
end do
!$acc parallel copy(arr) num_gangs(32) num_workers(8) vector_length(32)
!$acc loop gang private(x)
do i = 1, 32
x = i * 2;
arr(i) = arr(i) + x
end do
!$acc end parallel
do i = 1, 32
if (arr(i) .ne. i * 3) STOP 1
end do
end subroutine t1
! Test of gang-private addressable variable declared on loop directive, with
! broadcasting to partitioned workers.
subroutine t2(pt)
integer i, j, arr(0:32*32)
type(vec3), optional :: pt
do i = 0, 32*32-1
arr(i) = i
end do
!$acc parallel copy(arr) num_gangs(32) num_workers(8) vector_length(32)
!$acc loop gang private(pt)
do i = 0, 31
pt%x = i
pt%y = i * 2
pt%z = i * 4
pt%attr(5) = i * 6
!$acc loop vector
do j = 0, 31
arr(i * 32 + j) = arr(i * 32 + j) + pt%x + pt%y + pt%z + pt%attr(5);
end do
end do
!$acc end parallel
do i = 0, 32 * 32 - 1
if (arr(i) .ne. i + (i / 32) * 13) STOP 2
end do
end subroutine t2
! Test of vector-private variables declared on loop directive. Array type.
subroutine t3(pt)
integer, optional :: pt(2)
integer :: i, j, k, idx, arr(0:32*32*32)
do i = 0, 32*32*32-1
arr(i) = i
end do
!$acc parallel copy(arr) num_gangs(32) num_workers(8) vector_length(32)
!$acc loop gang
do i = 0, 31
!$acc loop worker
do j = 0, 31
!$acc loop vector private(pt)
do k = 0, 31
pt(1) = ieor(i, j * 3)
pt(2) = ior(i, j * 5)
arr(i * 1024 + j * 32 + k) = arr(i * 1024 + j * 32 + k) + pt(1) * k
arr(i * 1024 + j * 32 + k) = arr(i * 1024 + j * 32 + k) + pt(2) * k
end do
end do
end do
!$acc end parallel
do i = 0, 32 - 1
do j = 0, 32 -1
do k = 0, 32 - 1
idx = i * 1024 + j * 32 + k
if (arr(idx) .ne. idx + ieor(i, j * 3) * k + ior(i, j * 5) * k) then
STOP 3
end if
end do
end do
end do
end subroutine t3
end program main

69
libgomp/testsuite/libgomp.oacc-fortran/optional-reduction.f90 Normal file
View File

@ -0,0 +1,69 @@
! Test optional arguments in reduction clauses. The effect of
! non-present arguments in reduction clauses is undefined, and is not tested
! for. The tests are based on those in reduction-1.f90.
! { dg-do run }
! { dg-additional-options "-w" }
program optional_reduction
implicit none
integer :: rg, rw, rv, rc
rg = 0
rw = 0
rv = 0
rc = 0
call do_test(rg, rw, rv, rc)
contains
subroutine do_test(rg, rw, rv, rc)
integer, parameter :: n = 10, ng = 8, nw = 4, vl = 32
integer, optional :: rg, rw, rv, rc
integer :: i, vresult
integer, dimension (n) :: array
vresult = 0
do i = 1, n
array(i) = i
end do
!$acc parallel num_gangs(ng) copy(rg)
!$acc loop reduction(+:rg) gang
do i = 1, n
rg = rg + array(i)
end do
!$acc end parallel
!$acc parallel num_workers(nw) copy(rw)
!$acc loop reduction(+:rw) worker
do i = 1, n
rw = rw + array(i)
end do
!$acc end parallel
!$acc parallel vector_length(vl) copy(rv)
!$acc loop reduction(+:rv) vector
do i = 1, n
rv = rv + array(i)
end do
!$acc end parallel
!$acc parallel num_gangs(ng) num_workers(nw) vector_length(vl) copy(rc)
!$acc loop reduction(+:rc) gang worker vector
do i = 1, n
rc = rc + array(i)
end do
!$acc end parallel
! Verify the results
do i = 1, n
vresult = vresult + array(i)
end do
if (rg .ne. vresult) STOP 1
if (rw .ne. vresult) STOP 2
if (rv .ne. vresult) STOP 3
if (rc .ne. vresult) STOP 4
end subroutine do_test
end program optional_reduction

121
libgomp/testsuite/libgomp.oacc-fortran/optional-update-device.f90 Normal file
View File

@ -0,0 +1,121 @@
! Test OpenACC update to device with an optional argument.
! { dg-do run }
program optional_update_device
implicit none
integer, parameter :: n = 64
integer :: i
integer :: a_int, b_int, res_int
integer :: a_arr(n), b_arr(n), res_arr(n)
integer, allocatable :: a_alloc(:), b_alloc(:), res_alloc(:)
a_int = 5
b_int = 11
call test_int(res_int, a_int)
if (res_int .ne. a_int) stop 1
call test_int(res_int, a_int, b_int)
if (res_int .ne. a_int * b_int) stop 2
res_arr(:) = 0
do i = 1, n
a_arr(i) = i
b_arr(i) = n - i + 1
end do
call test_array(res_arr, a_arr)
do i = 1, n
if (res_arr(i) .ne. a_arr(i)) stop 3
end do
call test_array(res_arr, a_arr, b_arr)
do i = 1, n
if (res_arr(i) .ne. a_arr(i) * b_arr(i)) stop 4
end do
allocate (a_alloc(n))
allocate (b_alloc(n))
allocate (res_alloc(n))
res_alloc(:) = 0
do i = 1, n
a_alloc(i) = i
b_alloc(i) = n - i + 1
end do
call test_allocatable(res_alloc, a_alloc)
do i = 1, n
if (res_alloc(i) .ne. a_alloc(i)) stop 5
end do
call test_allocatable(res_alloc, a_alloc, b_alloc)
do i = 1, n
if (res_alloc(i) .ne. a_alloc(i) * b_alloc(i)) stop 6
end do
deallocate (a_alloc)
deallocate (b_alloc)
deallocate (res_alloc)
contains
subroutine test_int(res, a, b)
integer :: res
integer :: a
integer, optional :: b
!$acc data create(a, b, res)
!$acc update device(a, b)
!$acc parallel
res = a
if (present(b)) res = res * b
!$acc end parallel
!$acc update self(res)
!$acc end data
end subroutine test_int
subroutine test_array(res, a, b)
integer :: res(n)
integer :: a(n)
integer, optional :: b(n)
!$acc data create(a, b, res)
!$acc update device(a, b)
!$acc parallel loop
do i = 1, n
res(i) = a(i)
end do
!$acc parallel loop
do i = 1, n
if (present(b)) then
res(i) = res(i) * b(i)
end if
end do
!$acc update self(res)
!$acc end data
end subroutine test_array
subroutine test_allocatable(res, a, b)
integer, allocatable :: res(:)
integer, allocatable :: a(:)
integer, allocatable, optional :: b(:)
!$acc data create(a, b, res)
!$acc update device(a, b)
!$acc parallel loop
do i = 1, n
res(i) = a(i)
end do
!$acc parallel loop
do i = 1, n
if (present(b)) then
res(i) = res(i) * b(i)
end if
end do
!$acc update self(res)
!$acc end data
end subroutine test_allocatable
end program optional_update_device

115
libgomp/testsuite/libgomp.oacc-fortran/optional-update-host.f90 Normal file
View File

@ -0,0 +1,115 @@
! Test OpenACC update to host with an optional argument.
! { dg-do run }
program optional_update_host
implicit none
integer, parameter :: n = 64
integer :: i
integer :: a_int, b_int, res_int
integer :: a_arr(n), b_arr(n), res_arr(n)
integer, allocatable :: a_alloc(:), b_alloc(:), res_alloc(:)
a_int = 5
b_int = 11
res_int = 0
call test_int(a_int, b_int)
if (res_int .ne. 0) stop 1
call test_int(a_int, b_int, res_int)
if (res_int .ne. a_int * b_int) stop 2
res_arr(:) = 0
do i = 1, n
a_arr(i) = i
b_arr(i) = n - i + 1
end do
call test_array(a_arr, b_arr)
do i = 1, n
if (res_arr(i) .ne. 0) stop 1
end do
call test_array(a_arr, b_arr, res_arr)
do i = 1, n
if (res_arr(i) .ne. a_arr(i) * b_arr(i)) stop 2
end do
allocate(a_alloc(n))
allocate(b_alloc(n))
allocate(res_alloc(n))
res_alloc(:) = 0
do i = 1, n
a_alloc(i) = i
b_alloc(i) = n - i + 1
end do
call test_allocatable(a_alloc, b_alloc)
do i = 1, n
if (res_alloc(i) .ne. 0) stop 1
end do
call test_allocatable(a_alloc, b_alloc, res_alloc)
do i = 1, n
if (res_alloc(i) .ne. a_alloc(i) * b_alloc(i)) stop 2
end do
deallocate(a_alloc)
deallocate(b_alloc)
deallocate(res_alloc)
contains
subroutine test_int(a, b, res)
integer :: a, b
integer, optional :: res
!$acc data create(a, b, res)
!$acc update device(a, b)
!$acc parallel
if (present(res)) res = a
if (present(res)) res = res * b
!$acc end parallel
!$acc update self(res)
!$acc end data
end subroutine test_int
subroutine test_array(a, b, res)
integer :: a(n), b(n)
integer, optional :: res(n)
!$acc data create(a, b, res)
!$acc update device(a, b)
!$acc parallel loop
do i = 1, n
if (present(res)) res(i) = a(i)
end do
!$acc parallel loop
do i = 1, n
if (present(res)) res(i) = res(i) * b(i)
end do
!$acc update self(res)
!$acc end data
end subroutine test_array
subroutine test_allocatable(a, b, res)
integer, allocatable :: a(:), b(:)
integer, allocatable, optional :: res(:)
!$acc data create(a, b, res)
!$acc update device(a, b)
!$acc parallel loop
do i = 1, n
if (present(res)) res(i) = a(i)
end do
!$acc parallel loop
do i = 1, n
if (present(res)) res(i) = res(i) * b(i)
end do
!$acc update self(res)
!$acc end data
end subroutine test_allocatable
end program optional_update_host