https://gcc.gnu.org/g:65286465b94cba6ee3d59edbc771bef0088ac46e
commit r15-6821-g65286465b94cba6ee3d59edbc771bef0088ac46e
Author: Tobias Burnus <tbur...@baylibre.com>
Date: Sat Jan 11 12:54:56 2025 +0100
Fortran: Fix location_t in gfc_get_extern_function_decl; support 'omp
dispatch interop'
The declaration created by gfc_get_extern_function_decl used input_location
as DECL_SOURCE_LOCATION, which gave rather odd results with 'declared here'
diagnostic. - It is much more useful to use the gfc_symbol's declated_at,
which this commit now does.
Additionally, it adds support for the 'interop' clause of OpenMP's
'dispatch' directive. As the argument order matters,
gfc_match_omp_variable_list gained a 'reverse_order' flag to use the
same order as the C/C++ parser.
gcc/fortran/ChangeLog:
* gfortran.h: Add OMP_LIST_INTEROP to the unnamed OMP_LIST_ enum.
* openmp.cc (gfc_match_omp_variable_list): Add reverse_order
boolean argument, defaulting to false.
(enum omp_mask2, OMP_DISPATCH_CLAUSES): Add OMP_CLAUSE_INTEROP.
(gfc_match_omp_clauses, resolve_omp_clauses): Handle dispatch's
'interop' clause.
* trans-decl.cc (gfc_get_extern_function_decl): Use sym->declared_at
instead input_location as DECL_SOURCE_LOCATION.
* trans-openmp.cc (gfc_trans_omp_clauses): Handle OMP_LIST_INTEROP.
gcc/testsuite/ChangeLog:
* gfortran.dg/goacc/routine-external-level-of-parallelism-2.f:
Update
xfail'ed 'dg-bogus' for the better 'declared here' location.
* gfortran.dg/gomp/dispatch-11.f90: New test.
* gfortran.dg/gomp/dispatch-12.f90: New test.
Diff:
---
gcc/fortran/gfortran.h | 1 +
gcc/fortran/openmp.cc | 53 +++++++++++---
gcc/fortran/trans-decl.cc | 2 +-
gcc/fortran/trans-openmp.cc | 3 +
.../routine-external-level-of-parallelism-2.f | 28 +++----
gcc/testsuite/gfortran.dg/gomp/dispatch-11.f90 | 85 ++++++++++++++++++++++
gcc/testsuite/gfortran.dg/gomp/dispatch-12.f90 | 49 +++++++++++++
7 files changed, 195 insertions(+), 26 deletions(-)
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index aa495b5487e6..6293d85778c0 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1467,6 +1467,7 @@ enum
OMP_LIST_INIT,
OMP_LIST_USE,
OMP_LIST_DESTROY,
+ OMP_LIST_INTEROP,
OMP_LIST_ADJUST_ARGS,
OMP_LIST_NUM /* Must be the last. */
};
diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc
index 79c0f1b2e62a..e00044db7d08 100644
--- a/gcc/fortran/openmp.cc
+++ b/gcc/fortran/openmp.cc
@@ -408,7 +408,8 @@ gfc_match_omp_variable_list (const char *str,
gfc_omp_namelist **list,
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;
@@ -492,15 +493,20 @@ gfc_match_omp_variable_list (const char *str,
gfc_omp_namelist **list,
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);
@@ -540,13 +546,18 @@ gfc_match_omp_variable_list (const char *str,
gfc_omp_namelist **list,
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:
@@ -1128,6 +1139,7 @@ enum omp_mask2
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
};
@@ -3255,6 +3267,21 @@ gfc_match_omp_clauses (gfc_omp_clauses **cp, const
omp_mask mask,
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 (",
@@ -5019,7 +5046,7 @@ cleanup:
#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
@@ -8128,7 +8155,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses
*omp_clauses,
"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)
@@ -8455,6 +8482,7 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses
*omp_clauses,
&& 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)
@@ -8553,8 +8581,8 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses
*omp_clauses,
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
@@ -8564,7 +8592,8 @@ resolve_omp_clauses (gfc_code *code, gfc_omp_clauses
*omp_clauses,
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]);
}
diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 814a2055ecae..4ae22a5584d0 100644
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -2412,7 +2412,7 @@ module_sym:
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;
diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc
index b04adf3a14b1..635fcfda356a 100644
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -2780,6 +2780,9 @@ gfc_trans_omp_clauses (stmtblock_t *block,
gfc_omp_clauses *clauses,
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
diff --git
a/gcc/testsuite/gfortran.dg/goacc/routine-external-level-of-parallelism-2.f
b/gcc/testsuite/gfortran.dg/goacc/routine-external-level-of-parallelism-2.f
index 949d571ee55f..91898b11be54 100644
--- a/gcc/testsuite/gfortran.dg/goacc/routine-external-level-of-parallelism-2.f
+++ b/gcc/testsuite/gfortran.dg/goacc/routine-external-level-of-parallelism-2.f
@@ -7,6 +7,13 @@
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
@@ -22,8 +29,6 @@
! { 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
@@ -36,8 +41,6 @@
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
@@ -162,8 +165,6 @@
!$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
@@ -199,6 +200,13 @@
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
@@ -214,8 +222,6 @@
! { 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
@@ -228,9 +234,7 @@
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
@@ -354,8 +358,6 @@
!$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
diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-11.f90
b/gcc/testsuite/gfortran.dg/gomp/dispatch-11.f90
new file mode 100644
index 000000000000..2a909a3ca73e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-11.f90
@@ -0,0 +1,85 @@
+! { 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" } }
diff --git a/gcc/testsuite/gfortran.dg/gomp/dispatch-12.f90
b/gcc/testsuite/gfortran.dg/gomp/dispatch-12.f90
new file mode 100644
index 000000000000..93304a6e149e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/dispatch-12.f90
@@ -0,0 +1,49 @@
+! 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
