Re: [Patch] OpenMP/Fortran: Reject not strictly nested target -> teams [PR110725, PR71065]

[Tobias Burnus <tobias@codesourcery.com>]

[-- Attachment #1: Type: text/plain, Size: 744 bytes --]

Now committed as r14-2754-g2e31fe431b08b0 with a minor addition:

On 24.07.23 22:05, Tobias Burnus wrote:
> The current patch rejects nested blocks, be it 'omp target; block;
> block; omp teams;'
which was before in the testcase. But now also
> or be it 'omp target; block; block;end block; omp teams'.
is tested for.

Somehow, the second dg-error line in an modified testcase did not make
it in the first commit; now fixed in r14-2759-g50656980497d77

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

[-- Attachment #2: committed.diff --]
[-- Type: text/x-patch, Size: 1657 bytes --]

commit 50656980497d77ac12a5e7179013a6af09ba32f7
Author: Tobias Burnus <tobias@codesourcery.com>
Date:   Tue Jul 25 09:28:43 2023 +0200

    gfortran.dg/gomp/pr99226.f90: Add missing dg-error
    
    Follow up to r14-2754-g2e31fe431b08b0302e1fa8a1c18ee51adafd41df
    which added a check that a target region with teams does not
    have anything anything else strictly nested in the target.
    
    When changing the dg-error for this PR, somehow the addition of a
    dg-error in a second line was lost (the message uses (1) and (2) as
    location, showing two lines, both need a dg-error with the same message).
    
    gcc/testsuite/ChangeLog:
    
            * gfortran.dg/gomp/pr99226.f90: Update dg-error.
---
 gcc/testsuite/gfortran.dg/gomp/pr99226.f90 | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/gcc/testsuite/gfortran.dg/gomp/pr99226.f90 b/gcc/testsuite/gfortran.dg/gomp/pr99226.f90
index 2aea0c15585..d1b35076dd0 100644
--- a/gcc/testsuite/gfortran.dg/gomp/pr99226.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/pr99226.f90
@@ -3,7 +3,7 @@
 subroutine sub (n)
    integer :: n, i
    !$omp target	! { 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" }
-   !$omp teams distribute dist_schedule (static,n+4)
+   !$omp teams distribute dist_schedule (static,n+4)	! { 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" }
    do i = 1, 8
    end do
    !$omp teams distribute dist_schedule (static,n+4)

[-- Attachment #3: committed2.diff --]
[-- Type: text/x-patch, Size: 13783 bytes --]

commit 2e31fe431b08b0302e1fa8a1c18ee51adafd41df
Author: Tobias Burnus <tobias@codesourcery.com>
Date:   Mon Jul 24 22:57:07 2023 +0200

    OpenMP/Fortran: Reject not strictly nested target -> teams [PR110725, PR71065]
    
    OpenMP requires: "If a teams region is nested inside a target region, the
    corresponding target construct must not contain any statements, declarations
    or directives outside of the corresponding teams construct."
    
    This commit checks now for this restriction.
    
            PR fortran/110725
            PR middle-end/71065
    
    gcc/fortran/ChangeLog:
    
            * gfortran.h (gfc_omp_clauses): Add contains_teams_construct.
            * openmp.cc (resolve_omp_target): New; check for teams nesting.
            (gfc_resolve_omp_directive): Call it.
            * parse.cc (decode_omp_directive): Set contains_teams_construct
            on enclosing ST_OMP_TARGET.
    
    gcc/testsuite/ChangeLog:
    
            * gfortran.dg/gomp/pr99226.f90: Update dg-error.
            * gfortran.dg/gomp/teams-5.f90: New test.
---
 gcc/fortran/gfortran.h                     |   1 +
 gcc/fortran/openmp.cc                      |  39 +++++++-
 gcc/fortran/parse.cc                       |  33 +++++++
 gcc/testsuite/gfortran.dg/gomp/pr99226.f90 |   2 +-
 gcc/testsuite/gfortran.dg/gomp/teams-5.f90 | 150 +++++++++++++++++++++++++++++
 5 files changed, 223 insertions(+), 2 deletions(-)

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 6482a885211..577ef807af7 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -1575,6 +1575,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;
   ENUM_BITFIELD (gfc_omp_sched_kind) sched_kind:3;
   ENUM_BITFIELD (gfc_omp_device_type) device_type:2;
   ENUM_BITFIELD (gfc_omp_memorder) memorder:3;
diff --git a/gcc/fortran/openmp.cc b/gcc/fortran/openmp.cc
index 05a697da071..675011a18ce 100644
--- a/gcc/fortran/openmp.cc
+++ b/gcc/fortran/openmp.cc
@@ -10653,6 +10653,41 @@ gfc_resolve_oacc_directive (gfc_code *code, gfc_namespace *ns ATTRIBUTE_UNUSED)
 }
 
 
+static void
+resolve_omp_target (gfc_code *code)
+{
+#define GFC_IS_TEAMS_CONSTRUCT(op)			\
+  (op == EXEC_OMP_TEAMS					\
+   || op == EXEC_OMP_TEAMS_DISTRIBUTE			\
+   || op == EXEC_OMP_TEAMS_DISTRIBUTE_SIMD		\
+   || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO	\
+   || op == EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD	\
+   || op == EXEC_OMP_TEAMS_LOOP)
+
+  if (!code->ext.omp_clauses->contains_teams_construct)
+    return;
+  if ((GFC_IS_TEAMS_CONSTRUCT (code->block->next->op)
+       && code->block->next->next == NULL)
+      || (code->block->next->op == EXEC_BLOCK
+	  && code->block->next->next
+	  && GFC_IS_TEAMS_CONSTRUCT (code->block->next->next->op)
+	  && code->block->next->next->next == NULL))
+    return;
+  gfc_code *c = code->block->next;
+  while (c && !GFC_IS_TEAMS_CONSTRUCT (c->op))
+    c = c->next;
+  if (c)
+    gfc_error ("!$OMP TARGET region at %L with a nested TEAMS at %L may not "
+	       "contain any other statement, declaration or directive outside "
+	       "of the single TEAMS construct", &c->loc, &code->loc);
+  else
+    gfc_error ("!$OMP TARGET region at %L with a nested TEAMS may not "
+	       "contain any other statement, declaration or directive outside "
+	       "of the single TEAMS construct", &code->loc);
+#undef GFC_IS_TEAMS_CONSTRUCT
+}
+
+
 /* Resolve OpenMP directive clauses and check various requirements
    of each directive.  */
 
@@ -10703,6 +10738,9 @@ gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
     case EXEC_OMP_TEAMS_LOOP:
       resolve_omp_do (code);
       break;
+    case EXEC_OMP_TARGET:
+      resolve_omp_target (code);
+      gcc_fallthrough ();
     case EXEC_OMP_ALLOCATE:
     case EXEC_OMP_ALLOCATORS:
     case EXEC_OMP_ASSUME:
@@ -10718,7 +10756,6 @@ gfc_resolve_omp_directive (gfc_code *code, gfc_namespace *ns)
     case EXEC_OMP_SCOPE:
     case EXEC_OMP_SECTIONS:
     case EXEC_OMP_SINGLE:
-    case EXEC_OMP_TARGET:
     case EXEC_OMP_TARGET_DATA:
     case EXEC_OMP_TARGET_ENTER_DATA:
     case EXEC_OMP_TARGET_EXIT_DATA:
diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc
index e53b7a42e92..011a39c3d04 100644
--- a/gcc/fortran/parse.cc
+++ b/gcc/fortran/parse.cc
@@ -1312,6 +1312,39 @@ decode_omp_directive (void)
 	  prog_unit->omp_target_seen = true;
 	break;
       }
+    case ST_OMP_TEAMS:
+    case ST_OMP_TEAMS_DISTRIBUTE:
+    case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
+    case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
+    case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+    case ST_OMP_TEAMS_LOOP:
+      if (gfc_state_stack->previous && gfc_state_stack->previous->tail)
+	{
+	  gfc_state_data *stk = gfc_state_stack;
+	  do {
+	       stk = stk->previous;
+	     } while (stk && stk->tail && stk->tail->op == EXEC_BLOCK);
+	  if (stk && stk->tail)
+	    switch (stk->tail->op)
+	      {
+	      case EXEC_OMP_TARGET:
+	      case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
+	      case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
+	      case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
+	      case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
+	      case EXEC_OMP_TARGET_TEAMS_LOOP:
+	      case EXEC_OMP_TARGET_PARALLEL:
+	      case EXEC_OMP_TARGET_PARALLEL_DO:
+	      case EXEC_OMP_TARGET_PARALLEL_DO_SIMD:
+	      case EXEC_OMP_TARGET_PARALLEL_LOOP:
+	      case EXEC_OMP_TARGET_SIMD:
+		stk->tail->ext.omp_clauses->contains_teams_construct = 1;
+		break;
+	  default:
+	    break;
+	  }
+	}
+      break;
     case ST_OMP_ERROR:
       if (new_st.ext.omp_clauses->at != OMP_AT_EXECUTION)
 	return ST_NONE;
diff --git a/gcc/testsuite/gfortran.dg/gomp/pr99226.f90 b/gcc/testsuite/gfortran.dg/gomp/pr99226.f90
index 72dbdde2e28..2aea0c15585 100644
--- a/gcc/testsuite/gfortran.dg/gomp/pr99226.f90
+++ b/gcc/testsuite/gfortran.dg/gomp/pr99226.f90
@@ -2,7 +2,7 @@
 
 subroutine sub (n)
    integer :: n, i
-   !$omp target	! { dg-error "construct with nested 'teams' construct contains directives outside of the 'teams' construct" }
+   !$omp target	! { 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" }
    !$omp teams distribute dist_schedule (static,n+4)
    do i = 1, 8
    end do
diff --git a/gcc/testsuite/gfortran.dg/gomp/teams-5.f90 b/gcc/testsuite/gfortran.dg/gomp/teams-5.f90
new file mode 100644
index 00000000000..00377b69bf4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/gomp/teams-5.f90
@@ -0,0 +1,150 @@
+! { dg-do compile }
+
+! PR fortran/110725
+! PR middle-end/71065
+
+implicit none
+integer :: x
+!$omp target device(1)
+  block
+    !$omp teams num_teams(f())
+    !$omp end teams
+  end block
+!!$omp end target
+
+!$omp target device(1)
+  !$omp teams num_teams(f())
+  !$omp end teams
+!$omp end target
+
+!$omp target device(1)  ! { 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" }
+  x = 5
+  !$omp teams num_teams(f())  ! { 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" }
+  !$omp end teams
+!$omp end target
+
+!$omp target device(1)  ! { 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" }
+  !$omp teams num_teams(f())  ! { 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" }
+  !$omp end teams
+  x = 5
+!$omp end target
+
+!$omp target  ! { 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
+    block
+    !$omp teams num_teams(f())
+    !$omp end teams
+    end block
+  end block
+!$omp end target
+
+!$omp target device(1)  ! { 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
+    x = 5
+    !$omp teams num_teams(f())  ! { 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" }
+    !$omp end teams
+  end block
+!$omp end target
+
+!$omp target device(1)  ! { 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 teams num_teams(f())  ! { 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" }
+    !$omp end teams
+    x = 5
+  end block
+!$omp end target
+
+!$omp target device(1)  ! { 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 teams num_teams(f())  ! { 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" }
+    !$omp end teams
+    x = 5
+  end block
+!$omp end target
+
+!$omp target device(1)  ! { 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" }
+    !$omp teams num_teams(f())  ! { 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" }
+    !$omp end teams
+  block; end block
+!$omp end target
+
+!$omp target device(1)  ! { 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
+    block; end block;
+    !$omp teams num_teams(f())  ! { 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" }
+    !$omp end teams
+  end block
+!$omp end target
+
+!$omp target device(1)  ! { 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 teams num_teams(f())  ! { 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" }
+    !$omp end teams
+    block; end block;
+  end block
+!!$omp end target
+
+
+contains
+
+function f()
+  !$omp declare target
+  integer, allocatable :: f
+  f = 5
+end
+end
+
+subroutine sub1
+  implicit none
+  integer :: x,i
+
+  !$omp target device(1)  ! { 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 teams distribute num_teams(f())  ! { 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" }
+    do i = 1, 5
+    end do
+    x = 7
+  end block
+  !$omp end target
+
+  !$omp target device(1)  ! { 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 teams loop num_teams(f())  ! { 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" }
+    do i = 1, 5
+    end do
+    x = 7
+  end block
+  !$omp end target
+
+  !$omp target device(1)  ! { 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" }
+    !$omp teams distribute simd num_teams(f())  ! { 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" }
+    do i = 1, 5
+    end do
+    x = 7
+  !$omp end target
+
+  !$omp target device(1)  ! { 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" }
+    !$omp teams distribute parallel do num_teams(f())  ! { 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" }
+    do i = 1, 5
+    end do
+    x = 7
+  !$omp end target
+
+  !$omp target device(1)  ! { 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
+    x = 7
+    !$omp teams distribute parallel do simd num_teams(f())  ! { 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" }
+    do i = 1, 5
+    end do
+  end block
+  !$omp end target
+
+contains
+
+function f()
+  !$omp declare target
+  integer, allocatable :: f
+  f = 5
+end
+
+end