+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?
+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,
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)
}
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)
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)))
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));
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,
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)
{
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);
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
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,
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
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;
}
{
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);
}
+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
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);
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;
--- /dev/null
+! { 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
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
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
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
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
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
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
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
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
+++ /dev/null
-/* 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 "" } */
+++ /dev/null
-/* 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 "" } */
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
--- /dev/null
+! 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
projects / gcc.git / commitdiff