OMP_LIST_INIT,
OMP_LIST_USE,
OMP_LIST_DESTROY,
+ OMP_LIST_INTEROP,
OMP_LIST_ADJUST_ARGS,
OMP_LIST_NUM /* Must be the last. */
};
bool allow_sections = false,
bool allow_derived = false,
bool *has_all_memory = NULL,
- bool reject_common_vars = false)
+ bool reject_common_vars = false,
+ bool reverse_order = false)
{
gfc_omp_namelist *head, *tail, *p;
locus old_loc, cur_loc;
p = gfc_get_omp_namelist ();
if (head == NULL)
head = tail = p;
+ else if (reverse_order)
+ {
+ p->next = head;
+ head = p;
+ }
else
{
tail->next = p;
tail = tail->next;
}
- tail->sym = sym;
- tail->expr = expr;
- tail->where = gfc_get_location_range (NULL, 0, &cur_loc, 1,
- &gfc_current_locus);
+ p->sym = sym;
+ p->expr = expr;
+ p->where = gfc_get_location_range (NULL, 0, &cur_loc, 1,
+ &gfc_current_locus);
if (reject_common_vars && sym->attr.in_common)
{
gcc_assert (allow_common);
p = gfc_get_omp_namelist ();
if (head == NULL)
head = tail = p;
+ else if (reverse_order)
+ {
+ p->next = head;
+ head = p;
+ }
else
{
tail->next = p;
tail = tail->next;
}
- tail->sym = sym;
- tail->where = cur_loc;
+ p->sym = sym;
+ p->where = cur_loc;
}
next_item:
OMP_CLAUSE_USE, /* OpenMP 5.1. */
OMP_CLAUSE_NOVARIANTS, /* OpenMP 5.1 */
OMP_CLAUSE_NOCONTEXT, /* OpenMP 5.1 */
+ OMP_CLAUSE_INTEROP, /* OpenMP 5.1 */
/* This must come last. */
OMP_MASK2_LAST
};
continue;
goto error;
}
+ if ((mask & OMP_CLAUSE_INTEROP)
+ && (m = gfc_match_dupl_check (!c->lists[OMP_LIST_INTEROP],
+ "interop", true)) != MATCH_NO)
+ {
+ /* Note: the interop objects are saved in reverse order to match
+ the order in C/C++. */
+ if (m == MATCH_YES
+ && (gfc_match_omp_variable_list ("",
+ &c->lists[OMP_LIST_INTEROP],
+ false, NULL, NULL, false,
+ false, NULL, false, true)
+ == MATCH_YES))
+ continue;
+ goto error;
+ }
if ((mask & OMP_CLAUSE_IS_DEVICE_PTR)
&& gfc_match_omp_variable_list
("is_device_ptr (",
#define OMP_DISPATCH_CLAUSES \
(omp_mask (OMP_CLAUSE_DEVICE) | OMP_CLAUSE_DEPEND | OMP_CLAUSE_NOVARIANTS \
| OMP_CLAUSE_NOCONTEXT | OMP_CLAUSE_IS_DEVICE_PTR | OMP_CLAUSE_NOWAIT \
- | OMP_CLAUSE_HAS_DEVICE_ADDR)
+ | OMP_CLAUSE_HAS_DEVICE_ADDR | OMP_CLAUSE_INTEROP)
static match
"DEVICE_RESIDENT", "LINK", "USE_DEVICE",
"CACHE", "IS_DEVICE_PTR", "USE_DEVICE_PTR", "USE_DEVICE_ADDR",
"NONTEMPORAL", "ALLOCATE", "HAS_DEVICE_ADDR", "ENTER",
- "USES_ALLOCATORS", "INIT", "USE", "DESTROY", "ADJUST_ARGS" };
+ "USES_ALLOCATORS", "INIT", "USE", "DESTROY", "INTEROP", "ADJUST_ARGS" };
STATIC_ASSERT (ARRAY_SIZE (clause_names) == OMP_LIST_NUM);
if (omp_clauses == NULL)
&& list != OMP_LIST_DEPEND
&& list != OMP_LIST_FROM
&& list != OMP_LIST_TO
+ && list != OMP_LIST_INTEROP
&& (list != OMP_LIST_REDUCTION || !openacc)
&& list != OMP_LIST_ALLOCATE)
for (n = omp_clauses->lists[list]; n; n = n->next)
break;
}
}
- if (code && code->op == EXEC_OMP_INTEROP)
- for (list = OMP_LIST_INIT; list <= OMP_LIST_DESTROY; list++)
+ if (code && (code->op == EXEC_OMP_INTEROP || code->op == EXEC_OMP_DISPATCH))
+ for (list = OMP_LIST_INIT; list <= OMP_LIST_INTEROP; list++)
for (n = omp_clauses->lists[list]; n; n = n->next)
{
if (n->sym->ts.type != BT_INTEGER
gfc_error ("%qs at %L in %qs clause must be a scalar integer "
"variable of %<omp_interop_kind%> kind", n->sym->name,
&n->where, clause_names[list]);
- if (list != OMP_LIST_USE && n->sym->attr.intent == INTENT_IN)
+ if (list != OMP_LIST_USE && list != OMP_LIST_INTEROP
+ && n->sym->attr.intent == INTENT_IN)
gfc_error ("%qs at %L in %qs clause must be definable",
n->sym->name, &n->where, clause_names[list]);
}
type = gfc_get_function_type (sym, actual_args, fnspec);
- fndecl = build_decl (input_location,
+ fndecl = build_decl (gfc_get_location (&sym->declared_at),
FUNCTION_DECL, name, type);
/* Initialize DECL_EXTERNAL and TREE_PUBLIC before calling decl_attributes;
case OMP_LIST_DESTROY:
clause_code = OMP_CLAUSE_DESTROY;
goto add_clause;
+ case OMP_LIST_INTEROP:
+ clause_code = OMP_CLAUSE_INTEROP;
+ goto add_clause;
add_clause:
omp_clauses
integer, parameter :: n = 100
integer :: a(n), i, j
external :: gangr, workerr, vectorr, seqr
+! { dg-bogus "note: routine 'gangr' declared here" "TODO1" { xfail { ! offloading_enabled } } .-1 }
+! { dg-bogus "note: routine 'gangr_' declared here" "TODO2" { xfail offloading_enabled } .-2 }
+! { dg-bogus "note: routine 'workerr' declared here" "TODO1" { xfail { ! offloading_enabled } } .-3 }
+! { dg-bogus "note: routine 'workerr_' declared here" "TODO2" { xfail offloading_enabled } .-4 }
+! { dg-bogus "note: routine 'vectorr' declared here" "TODO1" { xfail { ! offloading_enabled } } .-5 }
+! { dg-bogus "note: routine 'vectorr_' declared here" "TODO2" { xfail offloading_enabled } .-6 }
+
!$acc routine (gangr) gang
!$acc routine (workerr) worker
!$acc routine (vectorr) vector
! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 }
do j = 1, n
call workerr (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" }
-! { dg-bogus "note: routine 'workerr' declared here" "TODO1" { xfail { ! offloading_enabled } } .-1 }
-! { dg-bogus "note: routine 'workerr_' declared here" "TODO2" { xfail offloading_enabled } .-2 }
end do
end do
!$acc end parallel loop
do j = 1, n
call gangr (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" }
! { dg-error "routine call uses same OpenACC parallelism as containing loop" "" { target *-*-* } .-1 }
-! { dg-bogus "note: routine 'gangr' declared here" "TODO1" { xfail { ! offloading_enabled } } .-2 }
-! { dg-bogus "note: routine 'gangr_' declared here" "TODO2" { xfail offloading_enabled } .-3 }
end do
end do
!$acc end parallel loop
!$acc parallel loop ! { dg-message "optimized: assigned OpenACC gang worker loop parallelism" }
do i = 1, n
call vectorr (a, n) ! { dg-message "optimized: assigned OpenACC vector loop parallelism" }
-! { dg-bogus "note: routine 'vectorr' declared here" "TODO1" { xfail { ! offloading_enabled } } .-1 }
-! { dg-bogus "note: routine 'vectorr_' declared here" "TODO2" { xfail offloading_enabled } .-2 }
end do
!$acc end parallel loop
integer, parameter :: n = 100
integer :: a(n), i, j
integer, external :: gangf, workerf, vectorf, seqf
+! { dg-bogus "note: routine 'gangf' declared here" "TODO1" { xfail { ! offloading_enabled } } .-1 }
+! { dg-bogus "note: routine 'gangf_' declared here" "TODO2" { xfail offloading_enabled } .-2 }
+! { dg-bogus "note: routine 'workerf' declared here" "TODO1" { xfail { ! offloading_enabled } } .-3 }
+! { dg-bogus "note: routine 'workerf_' declared here" "TODO2" { xfail offloading_enabled } .-4 }
+! { dg-bogus "note: routine 'vectorf' declared here" "TODO1" { xfail { ! offloading_enabled } } .-5 }
+! { dg-bogus "note: routine 'vectorf_' declared here" "TODO2" { xfail offloading_enabled } .-6 }
+
!$acc routine (gangf) gang
!$acc routine (workerf) worker
!$acc routine (vectorf) vector
! { dg-warning "insufficient partitioning available to parallelize loop" "" { target *-*-* } .-1 }
do j = 1, n
a(i) = workerf (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" }
-! { dg-bogus "note: routine 'workerf' declared here" "TODO1" { xfail { ! offloading_enabled } } .-1 }
-! { dg-bogus "note: routine 'workerf_' declared here" "TODO2" { xfail offloading_enabled } .-2 }
end do
end do
!$acc end parallel loop
do j = 1, n
a(i) = gangf (a, n) ! { dg-message "optimized: assigned OpenACC worker vector loop parallelism" }
! { dg-error "routine call uses same OpenACC parallelism as containing loop" "" { target *-*-* } .-1 }
-! { dg-bogus "note: routine 'gangf' declared here" "TODO1" { xfail { ! offloading_enabled } } .-2 }
-! { dg-bogus "note: routine 'gangf_' declared here" "TODO2" { xfail offloading_enabled } .-3 }
- end do
+ end do
end do
!$acc end parallel loop
!$acc parallel loop ! { dg-message "optimized: assigned OpenACC gang worker loop parallelism" }
do i = 1, n
a(i) = vectorf (a, n) ! { dg-message "optimized: assigned OpenACC vector loop parallelism" }
-! { dg-bogus "note: routine 'vectorf' declared here" "TODO1" { xfail { ! offloading_enabled } } .-1 }
-! { dg-bogus "note: routine 'vectorf_' declared here" "TODO2" { xfail offloading_enabled } .-2 }
end do
!$acc end parallel loop
--- /dev/null
+! { dg-additional-options "-fdump-tree-original" }
+
+! The following definitions are in omp_lib, which cannot be included
+! in gcc/testsuite/
+
+module m
+ use iso_c_binding
+ implicit none (type, external)
+
+ integer, parameter :: omp_interop_kind = c_intptr_t
+ integer, parameter :: omp_interop_none = 0_omp_interop_kind
+
+ interface
+ real function repl1(); end ! { dg-note "'declare variant' candidate 'repl1' declared here" }
+
+ real function base1()
+! { dg-note "'base1' declared here" "" { target *-*-* } .-1 }
+ !$omp declare variant(repl1) match(construct={dispatch})
+ end
+
+ subroutine repl2 (x1, x2) ! { dg-note "'declare variant' candidate 'repl2' declared here" }
+ import
+ type(c_ptr), value :: x1, x2
+ end
+ subroutine base2 (x, y)
+! { dg-note "'base2' declared here" "" { target *-*-* } .-1 }
+ import
+ type(c_ptr), value :: x, y
+ !$omp declare variant(repl2) match(construct={dispatch}) adjust_args(need_device_ptr : y)
+ end
+ end interface
+
+contains
+
+real function dupl (a, b)
+ type(c_ptr), value :: a, b
+ integer(omp_interop_kind) :: obj1, obj2
+ real :: x
+
+ !$omp dispatch interop ( obj1, obj2) device(2)
+ x = base1 ()
+ ! { dg-error "number of list items in 'interop' clause \\(2\\) exceeds the number of 'append_args' items \\(0\\) for 'declare variant' candidate 'repl1'" "" { target *-*-* } .-1 }
+
+ !$omp dispatch device(9) interop ( obj1, obj2) nocontext(.true.)
+ call base2 (a, b)
+ ! { dg-error "unexpected 'interop' clause as invoked procedure 'base2' is not variant substituted" "" { target *-*-* } .-1 }
+ dupl = x
+end
+
+real function test (a, b)
+ type(c_ptr), value :: a, b
+ integer(omp_interop_kind) :: obj1, obj2
+ real :: x, y
+
+ !$omp dispatch interop ( obj1 )
+ x = base1 ()
+ ! { dg-error "number of list items in 'interop' clause \\(1\\) exceeds the number of 'append_args' items \\(0\\) for 'declare variant' candidate 'repl1'" "" { target *-*-* } .-1 }
+
+ !$omp dispatch interop ( obj1, obj1 ) device(42) ! Twice the same - should be fine.
+ x = base1 ()
+ ! { dg-error "number of list items in 'interop' clause \\(2\\) exceeds the number of 'append_args' items \\(0\\) for 'declare variant' candidate 'repl1'" "" { target *-*-* } .-1 }
+
+ !$omp dispatch novariants(.true.) interop(obj2, obj1) device(0)
+ y = base1 ()
+ ! { dg-error "unexpected 'interop' clause as invoked procedure 'base1' is not variant substituted" "" { target *-*-* } .-1 }
+
+ !$omp dispatch interop(obj2, obj1) device(3)
+ call base2 (a, b)
+ ! { dg-error "number of list items in 'interop' clause \\(2\\) exceeds the number of 'append_args' items \\(0\\) for 'declare variant' candidate 'repl2'" "" { target *-*-* } .-1 }
+
+ !$omp dispatch interop(obj2) nocontext(.true.)
+ call base2 (a, b)
+ ! { dg-error "unexpected 'interop' clause as invoked procedure 'base2' is not variant substituted" "" { target *-*-* } .-1 }
+ test = x + y
+end
+end module
+
+
+! { dg-final { scan-tree-dump-times "#pragma omp dispatch interop\\(obj2\\) interop\\(obj1\\) device\\(2\\)\[\\n\\r\]" 1 "original" } }
+! { dg-final { scan-tree-dump-times "#pragma omp dispatch interop\\(obj2\\) interop\\(obj1\\) nocontext\\(1\\) device\\(9\\)\[\\n\\r\]" 1 "original" } }
+! { dg-final { scan-tree-dump-times "#pragma omp dispatch interop\\(obj1\\)\[\\n\\r\]" 1 "original" } }
+! { dg-final { scan-tree-dump-times "#pragma omp dispatch interop\\(obj1\\) interop\\(obj1\\) device\\(42\\)\[\\n\\r\]" 1 "original" } }
+! { dg-final { scan-tree-dump-times "#pragma omp dispatch interop\\(obj1\\) interop\\(obj2\\) novariants\\(1\\) device\\(0\\)\[\\n\\r\]" 1 "original" } }
+! { dg-final { scan-tree-dump-times "#pragma omp dispatch interop\\(obj1\\) interop\\(obj2\\) device\\(3\\)\[\\n\\r\]" 1 "original" } }
+! { dg-final { scan-tree-dump-times "#pragma omp dispatch interop\\(obj2\\) nocontext\\(1\\)\[\\n\\r\]" 1 "original" } }
--- /dev/null
+! The following definitions are in omp_lib, which cannot be included
+! in gcc/testsuite/
+
+module m
+ use iso_c_binding
+ implicit none (type, external)
+
+ integer, parameter :: omp_interop_kind = c_intptr_t
+ integer, parameter :: omp_interop_none = 0_omp_interop_kind
+
+ interface
+ subroutine repl1(); end
+
+ subroutine base1()
+ !$omp declare variant(repl1) match(construct={dispatch})
+ end
+ end interface
+
+contains
+ subroutine test (obj1)
+ integer(omp_interop_kind), intent(in) :: obj1
+ integer(omp_interop_kind) :: obj2(2)
+ integer(omp_interop_kind), parameter :: obj3 = omp_interop_none
+ integer(1) :: x
+
+ !$omp dispatch interop ( obj1, obj2, obj1 ) device(2) ! { dg-error "'obj2' at .1. in 'INTEROP' clause must be a scalar integer variable of 'omp_interop_kind' kind" }
+ call base1 ()
+
+ !$omp dispatch interop ( obj1, obj1, obj1 ) device(2) ! OK
+ call base1 ()
+
+ !$omp dispatch interop ( obj3 ) ! { dg-error "Object 'obj3' is not a variable at .1." }
+ call base1 ()
+ ! { dg-error "'obj3' at .1. in 'INTEROP' clause must be a scalar integer variable of 'omp_interop_kind' kind" "" { target *-*-* } .-2 }
+
+ !$omp dispatch interop ( obj1 )
+ call base1 ()
+
+ !$omp dispatch interop ( obj2 ) ! { dg-error "'obj2' at .1. in 'INTEROP' clause must be a scalar integer variable of 'omp_interop_kind' kind" }
+ call base1 ()
+
+ !$omp dispatch interop ( x ) ! { dg-error "'x' at .1. in 'INTEROP' clause must be a scalar integer variable of 'omp_interop_kind' kind" }
+ call base1 ()
+
+ !$omp dispatch interop ( obj1) device(2) interop (obj1 ) ! { dg-error "Duplicated 'interop' clause" }
+ call base1 ()
+
+ end
+end module
projects / thirdparty / gcc.git / commitdiff
