commit eae457d9aa6ccad1692759bffee8fa3f6c92a3a0 Author: Tobias Burnus 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(-) diff --git a/gcc/fortran/ChangeLog.omp b/gcc/fortran/ChangeLog.omp index c197f77f1f9..237e9ebeba2 100644 --- a/gcc/fortran/ChangeLog.omp +++ b/gcc/fortran/ChangeLog.omp @@ -1,3 +1,12 @@ +2023-07-27 Tobias Burnus + + * 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 Backported from master: diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 2cf8a0e0c39..0e7e80e4bf1 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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; diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc index 18a4a33feaa..deccb14a525 100644 --- a/gcc/fortran/openmp.cc +++ b/gcc/fortran/openmp.cc @@ -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) diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index 2070a8a7dee..efedde1d84b 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -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: diff --git a/libgomp/ChangeLog.omp b/libgomp/ChangeLog.omp index f83700f1c00..9f8e3ec947d 100644 --- a/libgomp/ChangeLog.omp +++ b/libgomp/ChangeLog.omp @@ -1,3 +1,8 @@ +2023-07-27 Tobias Burnus + + * testsuite/libgomp.fortran/metadirective-1.f90: Extend. + * testsuite/libgomp.fortran/metadirective-6.f90: New test. + 2023-07-26 Tobias Burnus Backported from master: diff --git a/libgomp/testsuite/libgomp.fortran/metadirective-1.f90 b/libgomp/testsuite/libgomp.fortran/metadirective-1.f90 index 9f6a07459e0..7b3e09f7c2a 100644 --- a/libgomp/testsuite/libgomp.fortran/metadirective-1.f90 +++ b/libgomp/testsuite/libgomp.fortran/metadirective-1.f90 @@ -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 diff --git a/libgomp/testsuite/libgomp.fortran/metadirective-6.f90 b/libgomp/testsuite/libgomp.fortran/metadirective-6.f90 new file mode 100644 index 00000000000..436fdbade2f --- /dev/null +++ b/libgomp/testsuite/libgomp.fortran/metadirective-6.f90 @@ -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