Yet another omission, the flag was not properly set for deeply buried
'omp teams' as I stopped too early when walking up the stack.
Now fixed by commit r14-2826-g081e25d3cfd86c
* * *
This was found when 'repairing' the feature on the OG13
(devel/omp/gcc-13) branch for metadirectives, cf. the second attached
patch, applied after cherry-picking the mainline patch.
Tobias
-----------------
Siemens Electronic Design Automation GmbH; Anschrift: Arnulfstraße 201, 80634 München; Gesellschaft mit beschränkter Haftung; Geschäftsführer: Thomas Heurung, Frank Thürauf; Sitz der Gesellschaft: München; Registergericht München, HRB 106955
commit eae457d9aa6ccad1692759bffee8fa3f6c92a3a0
Author: Tobias Burnus <tobias@codesourcery.com>
Date: Thu Jul 27 18:30:20 2023 +0200
OpenMP/Fortran: Fix target + teams diagnostic with metadirectives
gcc/fortran/ChangeLog:
* gfortran.h (gfc_omp_clauses): Rename target_first_st_is_teams
to target_first_st_is_teams_or_meta.
* parse.cc (parse_omp_structured_block): Handle metadirectives
for target_first_st_is_teams.
* openmp.cc (resolve_omp_target): Likewise to fix target+teams
diagnostic with metadirectives.
libgomp/ChangeLog:
* testsuite/libgomp.fortran/metadirective-1.f90: Extend.
* testsuite/libgomp.fortran/metadirective-6.f90: New test.
---
gcc/fortran/ChangeLog.omp | 9 ++++
gcc/fortran/gfortran.h | 2 +-
gcc/fortran/openmp.cc | 35 ++++++++++---
gcc/fortran/parse.cc | 4 +-
libgomp/ChangeLog.omp | 5 ++
.../testsuite/libgomp.fortran/metadirective-1.f90 | 28 +++++++++++
.../testsuite/libgomp.fortran/metadirective-6.f90 | 58 ++++++++++++++++++++++
7 files changed, 132 insertions(+), 9 deletions(-)
@@ -1,3 +1,12 @@
+2023-07-27 Tobias Burnus <tobias@codesourcery.com>
+
+ * gfortran.h (gfc_omp_clauses): Rename target_first_st_is_teams
+ to target_first_st_is_teams_or_meta.
+ * parse.cc (parse_omp_structured_block): Handle metadirectives
+ for target_first_st_is_teams.
+ * openmp.cc (resolve_omp_target): Likewise to fix target+teams
+ diagnostic with metadirectives.
+
2023-07-27 Tobias Burnus <tobias@codesourcery.com>
Backported from master:
@@ -1588,7 +1588,7 @@ typedef struct gfc_omp_clauses
unsigned order_unconstrained:1, order_reproducible:1, capture:1;
unsigned grainsize_strict:1, num_tasks_strict:1, compare:1, weak:1;
unsigned non_rectangular:1, order_concurrent:1;
- unsigned contains_teams_construct:1, target_first_st_is_teams:1;
+ unsigned contains_teams_construct:1, target_first_st_is_teams_or_meta:1;
unsigned unroll_full:1, unroll_none:1, unroll_partial:1;
unsigned unroll_partial_factor;
ENUM_BITFIELD (gfc_omp_sched_kind) sched_kind:3;
@@ -12252,13 +12252,34 @@ resolve_omp_target (gfc_code *code)
if (!code->ext.omp_clauses->contains_teams_construct)
return;
gfc_code *c = code->block->next;
- if (code->ext.omp_clauses->target_first_st_is_teams
- && ((GFC_IS_TEAMS_CONSTRUCT (c->op) && c->next == NULL)
- || (c->op == EXEC_BLOCK
- && c->next
- && GFC_IS_TEAMS_CONSTRUCT (c->next->op)
- && c->next->next == NULL)))
- return;
+ if (c->op == EXEC_BLOCK)
+ c = c->next;
+ if (code->ext.omp_clauses->target_first_st_is_teams_or_meta)
+ {
+ if (c->op == EXEC_OMP_METADIRECTIVE)
+ {
+ struct gfc_omp_metadirective_clause *mc
+ = c->ext.omp_metadirective_clauses;
+ /* All mc->(next...->)code should be identical with regards
+ to the diagnostic below. */
+ do
+ {
+ if (mc->stmt != ST_NONE
+ && GFC_IS_TEAMS_CONSTRUCT (mc->code->op))
+ {
+ if (c->next == NULL && mc->code->next == NULL)
+ return;
+ c = mc->code;
+ break;
+ }
+ mc = mc->next;
+ }
+ while (mc);
+ }
+ else if (GFC_IS_TEAMS_CONSTRUCT (c->op) && c->next == NULL)
+ return;
+ }
+
while (c && !GFC_IS_TEAMS_CONSTRUCT (c->op))
c = c->next;
if (c)
@@ -5833,9 +5833,11 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
case ST_OMP_TEAMS_LOOP:
+ case ST_OMP_METADIRECTIVE:
+ case ST_OMP_BEGIN_METADIRECTIVE:
{
gfc_state_data *stk = gfc_state_stack->previous;
- stk->tail->ext.omp_clauses->target_first_st_is_teams = true;
+ stk->tail->ext.omp_clauses->target_first_st_is_teams_or_meta = true;
break;
}
default:
@@ -1,3 +1,8 @@
+2023-07-27 Tobias Burnus <tobias@codesourcery.com>
+
+ * testsuite/libgomp.fortran/metadirective-1.f90: Extend.
+ * testsuite/libgomp.fortran/metadirective-6.f90: New test.
+
2023-07-26 Tobias Burnus <tobias@codesourcery.com>
Backported from master:
@@ -17,17 +17,45 @@ program test
do i = 1, N
if (z(i) .ne. x(i) * y(i)) stop 1
end do
+
+ ! -----
+ do i = 1, N
+ x(i) = i;
+ y(i) = -i;
+ end do
+
+ call g (x, y, z)
+
+ do i = 1, N
+ if (z(i) .ne. x(i) * y(i)) stop 1
+ end do
+
contains
subroutine f (x, y, z)
integer :: x(N), y(N), z(N)
!$omp target map (to: x, y) map(from: z)
+ block
+ !$omp metadirective &
+ !$omp& when(device={arch("nvptx")}: teams loop) &
+ !$omp& default(parallel loop)
+ do i = 1, N
+ z(i) = x(i) * y(i)
+ enddo
+ end block
+ end subroutine
+ subroutine g (x, y, z)
+ integer :: x(N), y(N), z(N)
+
+ !$omp target map (to: x, y) map(from: z)
+ block
!$omp metadirective &
!$omp& when(device={arch("nvptx")}: teams loop) &
!$omp& default(parallel loop)
do i = 1, N
z(i) = x(i) * y(i)
enddo
+ end block
!$omp end target
end subroutine
end program
new file mode 100644
@@ -0,0 +1,58 @@
+! { dg-do compile }
+
+program test
+ implicit none
+
+ integer, parameter :: N = 100
+ integer :: x(N), y(N), z(N)
+ integer :: i
+
+contains
+ subroutine f (x, y, z)
+ integer :: x(N), y(N), z(N)
+
+ !$omp target map (to: x, y) map(from: z) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS at .2. may not contain any other statement, declaration or directive outside of the single TEAMS construct" }
+ block
+ !$omp metadirective &
+ !$omp& when(device={arch("nvptx")}: teams loop) &
+ !$omp& default(parallel loop) ! { dg-error "\\(1\\)" }
+ ! FIXME: The line above should be the same error as above but some fails here with -fno-diagnostics-show-caret
+ ! Seems as if some gcc/testsuite/ fix is missing for libgomp/testsuite
+ do i = 1, N
+ z(i) = x(i) * y(i)
+ enddo
+ z(N) = z(N) + 1 ! <<< invalid
+ end block
+ end subroutine
+
+ subroutine f2 (x, y, z)
+ integer :: x(N), y(N), z(N)
+
+ !$omp target map (to: x, y) map(from: z) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS may not contain any other statement, declaration or directive outside of the single TEAMS construct" }
+ block
+ integer :: i ! << invalid
+ !$omp metadirective &
+ !$omp& when(device={arch("nvptx")}: teams loop) &
+ !$omp& default(parallel loop)
+ do i = 1, N
+ z(i) = x(i) * y(i)
+ enddo
+ end block
+ end subroutine
+ subroutine g (x, y, z)
+ integer :: x(N), y(N), z(N)
+
+ !$omp target map (to: x, y) map(from: z) ! { dg-error "OMP TARGET region at .1. with a nested TEAMS may not contain any other statement, declaration or directive outside of the single TEAMS construct" }
+ block
+ !$omp metadirective & ! <<<< invalid
+ !$omp& when(device={arch("nvptx")}: flush) &
+ !$omp& default(nothing)
+ !$omp teams loop
+ do i = 1, N
+ z(i) = x(i) * y(i)
+ enddo
+ end block
+ !$omp end target
+ end subroutine
+
+end program