The first change is a simple, generic Fortran change.
Without it, external declarations have odd locations (namely their input_location): gcc/testsuite/gfortran.dg/gomp/dispatch-11.f90:67:46: 67 | !$omp dispatch interop(obj2, obj1) device(3) | ^ note: ‘declare variant’ candidate ‘repl2’ declared here While with the change, i.e. gfc_get_location (&sym->declared_at), we get: gcc/testsuite/gfortran.dg/gomp/dispatch-11.f90:25:5: 25 | subroutine base2 (x, y) | ^~~~~~~~~~~~~~~~ note: ‘base2’ declared here I bet there are several other cases where we could/should improve the location data ... * * * Additionally, this patch adds the 'interop' clause to OpenMP's 'dispatch' clause. That change is a bit boring until also the 'append_args' clause of 'declare variant' is implemented, but it is a first step and already gives the proper middle end diagnostic. Otherwise it is just a list and the existing diagnostic can be reused. The only special part is that the list is ordered, which means that C/C++ and Fortran have to agree on the order to make it easier in the middle end. Thus, we store the clause arguments in reverse order, matching how a tree list is trivially constructed. * * * Comments, remarks, suggestions? Otherwise, I regard the common Fortran code as obvious - and the OpenMP part covered by my (co)maintainership. Hence, I intent to commit it later today. Nonetheless, I am happy about (nearly) any comment - it is useful if someone proof reads a patch :-) Thanks, Tobias
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 dows. 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. 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 aa495b5487e..6293d85778c 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 79c0f1b2e62..e00044db7d0 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 814a2055eca..4ae22a5584d 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 b04adf3a14b..635fcfda356 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 949d571ee55..91898b11be5 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 00000000000..2a909a3ca73 --- /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 00000000000..93304a6e149 --- /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