[flang][openacc] Handle optional end directive in combined construct

OpenACC combined construct can have an optional end directive. This patch handle this
case in the parsing/unparsing with a canonicalization step. Unlike OmpEndLoopDirective,
this doesn't need a special treatment in the pre-fir tree as there is no clause attached to
a AccEndCombinedDirective.

Reviewed By: klausler

Differential Revision: https://reviews.llvm.org/D84481

Author: clementval

flang/include/flang/Parser/parse-tree.h

@@ -258,6 +258,7 @@ struct AssignStmt;
 struct AssignedGotoStmt;
 struct PauseStmt;
 struct OpenACCConstruct;
+struct AccEndCombinedDirective;
 struct OpenACCDeclarativeConstruct;
 struct OpenMPConstruct;
 struct OpenMPDeclarativeConstruct;
@@ -517,6 +518,7 @@ struct ExecutableConstruct {
       common::Indirection<WhereConstruct>, common::Indirection<ForallConstruct>,
       common::Indirection<CompilerDirective>,
       common::Indirection<OpenACCConstruct>,
+      common::Indirection<AccEndCombinedDirective>,
       common::Indirection<OpenMPConstruct>,
       common::Indirection<OmpEndLoopDirective>>
       u;
@@ -3970,6 +3972,7 @@ struct OpenACCStandaloneDeclarativeConstruct {
 
 struct AccBeginCombinedDirective {
   TUPLE_CLASS_BOILERPLATE(AccBeginCombinedDirective);
+  CharBlock source;
   std::tuple<AccCombinedDirective, AccClauseList> t;
 };
 
@@ -3981,7 +3984,9 @@ struct AccEndCombinedDirective {
 struct OpenACCCombinedConstruct {
   TUPLE_CLASS_BOILERPLATE(OpenACCCombinedConstruct);
   CharBlock source;
-  std::tuple<AccBeginCombinedDirective, Block,
+  OpenACCCombinedConstruct(AccBeginCombinedDirective &&a)
+      : t({std::move(a), std::nullopt, std::nullopt}) {}
+  std::tuple<AccBeginCombinedDirective, std::optional<DoConstruct>,
       std::optional<AccEndCombinedDirective>>
       t;
 };

flang/lib/Parser/executable-parsers.cpp

@@ -50,8 +50,9 @@ constexpr auto executableConstruct{
         construct<ExecutableConstruct>(indirect(whereConstruct)),
         construct<ExecutableConstruct>(indirect(forallConstruct)),
         construct<ExecutableConstruct>(indirect(ompEndLoopDirective)),
-        construct<ExecutableConstruct>(indirect(openaccConstruct)),
         construct<ExecutableConstruct>(indirect(openmpConstruct)),
+        construct<ExecutableConstruct>(indirect(accEndCombinedDirective)),
+        construct<ExecutableConstruct>(indirect(openaccConstruct)),
         construct<ExecutableConstruct>(indirect(compilerDirective)))};
 
 // R510 execution-part-construct ->

flang/lib/Parser/openacc-parsers.cpp

@@ -199,16 +199,9 @@ TYPE_PARSER(sourced(
         parenthesized(Parser<AccObjectListWithModifier>{}))))
 
 // 2.11 Combined constructs
-TYPE_PARSER(startAccLine >> construct<AccEndCombinedDirective>(sourced(
-                                "END"_tok >> Parser<AccCombinedDirective>{})))
-
 TYPE_PARSER(construct<AccBeginCombinedDirective>(
     sourced(Parser<AccCombinedDirective>{}), Parser<AccClauseList>{}))
 
-TYPE_PARSER(construct<OpenACCCombinedConstruct>(
-    Parser<AccBeginCombinedDirective>{} / endAccLine, block,
-    maybe(Parser<AccEndCombinedDirective>{} / endAccLine)))
-
 // 2.12 Atomic constructs
 TYPE_PARSER(construct<AccEndAtomic>(startAccLine >> "END ATOMIC"_tok))
 
@@ -281,4 +274,11 @@ TYPE_CONTEXT_PARSER("OpenACC construct"_en_US,
             construct<OpenACCConstruct>(Parser<OpenACCCacheConstruct>{}),
             construct<OpenACCConstruct>(Parser<OpenACCWaitConstruct>{}),
             construct<OpenACCConstruct>(Parser<OpenACCAtomicConstruct>{})))
+
+TYPE_PARSER(startAccLine >> sourced(construct<AccEndCombinedDirective>(sourced(
+                                "END"_tok >> Parser<AccCombinedDirective>{}))))
+
+TYPE_PARSER(construct<OpenACCCombinedConstruct>(
+    sourced(Parser<AccBeginCombinedDirective>{} / endAccLine)))
+
 } // namespace Fortran::parser

flang/lib/Parser/program-parsers.cpp

@@ -76,10 +76,10 @@ TYPE_CONTEXT_PARSER("specification part"_en_US,
 // are in contexts that impose constraints on the kinds of statements that
 // are allowed, and so we have a variant production for declaration-construct
 // that implements those constraints.
-constexpr auto execPartLookAhead{first(actionStmt >> ok,
-    ompEndLoopDirective >> ok, openaccConstruct >> ok, openmpConstruct >> ok,
-    "ASSOCIATE ("_tok, "BLOCK"_tok, "SELECT"_tok, "CHANGE TEAM"_sptok,
-    "CRITICAL"_tok, "DO"_tok, "IF ("_tok, "WHERE ("_tok, "FORALL ("_tok)};
+constexpr auto execPartLookAhead{
+    first(actionStmt >> ok, openaccConstruct >> ok, openmpConstruct >> ok,
+        "ASSOCIATE ("_tok, "BLOCK"_tok, "SELECT"_tok, "CHANGE TEAM"_sptok,
+        "CRITICAL"_tok, "DO"_tok, "IF ("_tok, "WHERE ("_tok, "FORALL ("_tok)};
 constexpr auto declErrorRecovery{
     stmtErrorRecoveryStart >> !execPartLookAhead >> skipStmtErrorRecovery};
 constexpr auto misplacedSpecificationStmt{Parser<UseStmt>{} >>

flang/lib/Parser/type-parsers.h

@@ -131,6 +131,7 @@ constexpr Parser<EntryStmt> entryStmt; // R1541
 constexpr Parser<ContainsStmt> containsStmt; // R1543
 constexpr Parser<CompilerDirective> compilerDirective;
 constexpr Parser<OpenACCConstruct> openaccConstruct;
+constexpr Parser<AccEndCombinedDirective> accEndCombinedDirective;
 constexpr Parser<OpenACCDeclarativeConstruct> openaccDeclarativeConstruct;
 constexpr Parser<OpenMPConstruct> openmpConstruct;
 constexpr Parser<OpenMPDeclarativeConstruct> openmpDeclarativeConstruct;

flang/lib/Parser/unparse.cpp

@@ -2104,10 +2104,9 @@ class UnparseVisitor {
     Walk(std::get<AccBeginCombinedDirective>(x.t));
     Put("\n");
     EndOpenACC();
-    Walk(std::get<Block>(x.t), "");
+    Walk(std::get<std::optional<DoConstruct>>(x.t));
     BeginOpenACC();
-    Word("!$ACC END ");
-    Walk(std::get<std::optional<AccEndCombinedDirective>>(x.t));
+    Walk("!$ACC END ", std::get<std::optional<DoConstruct>>(x.t));
     Put("\n");
     EndOpenACC();
   }

flang/lib/Semantics/canonicalize-acc.cpp

@@ -16,6 +16,9 @@
 //   1. move structured DoConstruct into
 //      OpenACCLoopConstruct. Compilation will not proceed in case of errors
 //      after this pass.
+//   2. move structured DoConstruct into OpenACCCombinedConstruct. Move
+//      AccEndCombinedConstruct into OpenACCCombinedConstruct if present.
+//      Compilation will not proceed in case of errors after this pass.
 namespace Fortran::semantics {
 
 using namespace parser::literals;
@@ -30,6 +33,16 @@ class CanonicalizationOfAcc {
     for (auto it{block.begin()}; it != block.end(); ++it) {
       if (auto *accLoop{parser::Unwrap<parser::OpenACCLoopConstruct>(*it)}) {
         RewriteOpenACCLoopConstruct(*accLoop, block, it);
+      } else if (auto *accCombined{
+                     parser::Unwrap<parser::OpenACCCombinedConstruct>(*it)}) {
+        RewriteOpenACCCombinedConstruct(*accCombined, block, it);
+      } else if (auto *endDir{
+                     parser::Unwrap<parser::AccEndCombinedDirective>(*it)}) {
+        // Unmatched AccEndCombinedDirective
+        messages_.Say(endDir->v.source,
+            "The %s directive must follow the DO loop associated with the "
+            "loop construct"_err_en_US,
+            parser::ToUpperCaseLetters(endDir->v.source.ToString()));
       }
     } // Block list
   }
@@ -73,6 +86,55 @@ class CanonicalizationOfAcc {
         parser::ToUpperCaseLetters(dir.source.ToString()));
   }
 
+  void RewriteOpenACCCombinedConstruct(parser::OpenACCCombinedConstruct &x,
+      parser::Block &block, parser::Block::iterator it) {
+    // Check the sequence of DoConstruct in the same iteration
+    //
+    // Original:
+    //   ExecutableConstruct -> OpenACCConstruct -> OpenACCCombinedConstruct
+    //     ACCBeginCombinedDirective
+    //   ExecutableConstruct -> DoConstruct
+    //   ExecutableConstruct -> AccEndCombinedDirective (if available)
+    //
+    // After rewriting:
+    //   ExecutableConstruct -> OpenACCConstruct -> OpenACCCombinedConstruct
+    //     ACCBeginCombinedDirective
+    //     DoConstruct
+    //     AccEndCombinedDirective (if available)
+    parser::Block::iterator nextIt;
+    auto &beginDir{std::get<parser::AccBeginCombinedDirective>(x.t)};
+    auto &dir{std::get<parser::AccCombinedDirective>(beginDir.t)};
+
+    nextIt = it;
+    if (++nextIt != block.end()) {
+      if (auto *doCons{parser::Unwrap<parser::DoConstruct>(*nextIt)}) {
+        if (doCons->GetLoopControl()) {
+          // move DoConstruct
+          std::get<std::optional<parser::DoConstruct>>(x.t) =
+              std::move(*doCons);
+          nextIt = block.erase(nextIt);
+          // try to match AccEndCombinedDirective
+          if (nextIt != block.end()) {
+            if (auto *endDir{
+                    parser::Unwrap<parser::AccEndCombinedDirective>(*nextIt)}) {
+              std::get<std::optional<parser::AccEndCombinedDirective>>(x.t) =
+                  std::move(*endDir);
+              block.erase(nextIt);
+            }
+          }
+        } else {
+          messages_.Say(dir.source,
+              "DO loop after the %s directive must have loop control"_err_en_US,
+              parser::ToUpperCaseLetters(dir.source.ToString()));
+        }
+        return; // found do-loop
+      }
+    }
+    messages_.Say(dir.source,
+        "A DO loop must follow the %s directive"_err_en_US,
+        parser::ToUpperCaseLetters(dir.source.ToString()));
+  }
+
   parser::Messages &messages_;
 };
 

flang/lib/Semantics/check-acc-structure.cpp

@@ -156,9 +156,17 @@ void AccStructureChecker::Leave(
 }
 
 void AccStructureChecker::Enter(const parser::OpenACCCombinedConstruct &x) {
-  const auto &beginBlockDir{std::get<parser::AccBeginCombinedDirective>(x.t)};
+  const auto &beginCombinedDir{
+      std::get<parser::AccBeginCombinedDirective>(x.t)};
   const auto &combinedDir{
-      std::get<parser::AccCombinedDirective>(beginBlockDir.t)};
+      std::get<parser::AccCombinedDirective>(beginCombinedDir.t)};
+
+  // check matching, End directive is optional
+  if (const auto &endCombinedDir{
+          std::get<std::optional<parser::AccEndCombinedDirective>>(x.t)}) {
+    CheckMatching<parser::AccCombinedDirective>(combinedDir, endCombinedDir->v);
+  }
+
   PushContextAndClauseSets(combinedDir.source, combinedDir.v);
 }
 

flang/test/Lower/pre-fir-tree05.f90

@@ -31,3 +31,19 @@ subroutine foo()
 end subroutine
 ! CHECK-NEXT: EndSubroutine foo
 
+! CHECK: Subroutine foo
+subroutine foo2()
+  ! CHECK-NEXT: <<OpenACCConstruct>>
+  !$acc parallel loop
+  ! CHECK-NEXT: <<DoConstruct>>
+  ! CHECK-NEXT: NonLabelDoStmt
+  do i=1,5
+  ! CHECK-NEXT: EndDoStmt
+  ! CHECK-NEXT: <<End DoConstruct>>
+  end do
+  !$acc end parallel loop
+  ! CHECK-NEXT: <<End OpenACCConstruct>>
+  ! CHECK-NEXT: ContinueStmt
+end subroutine
+! CHECK-NEXT: EndSubroutine foo2
+

flang/test/Semantics/acc-canonicalization-validity.f90

@@ -0,0 +1,95 @@
+! RUN: %S/test_errors.sh %s %t %f18 -fopenacc
+
+! Check OpenACC canonalization validity for the construct defined below:
+!   2.9 Loop
+!   2.11 Parallel Loop
+!   2.11 Kernels Loop
+!   2.11 Serial Loop
+
+program openacc_clause_validity
+
+  implicit none
+
+  integer :: i, j
+  integer :: N = 256
+  real(8) :: a(256)
+
+  !ERROR: A DO loop must follow the LOOP directive
+  !$acc loop
+  i = 1
+
+  !ERROR: DO loop after the LOOP directive must have loop control
+  !$acc loop
+  do
+  end do
+
+  !ERROR: A DO loop must follow the PARALLEL LOOP directive
+  !$acc parallel loop
+  i = 1
+
+  !ERROR: A DO loop must follow the KERNELS LOOP directive
+  !$acc kernels loop
+  i = 1
+
+  !ERROR: A DO loop must follow the SERIAL LOOP directive
+  !$acc serial loop
+  i = 1
+
+  !ERROR: The END PARALLEL LOOP directive must follow the DO loop associated with the loop construct
+  !$acc end parallel loop
+
+  !ERROR: The END KERNELS LOOP directive must follow the DO loop associated with the loop construct
+  !$acc end kernels loop
+
+  !ERROR: The END SERIAL LOOP directive must follow the DO loop associated with the loop construct
+  !$acc end serial loop
+
+  !$acc parallel loop
+  do i = 1, N
+    a(i) = 3.14
+  end do
+
+  !$acc kernels loop
+  do i = 1, N
+    a(i) = 3.14
+  end do
+
+  !$acc serial loop
+  do i = 1, N
+    a(i) = 3.14
+  end do
+
+  !$acc parallel loop
+  do i = 1, N
+    a(i) = 3.14
+  end do
+  !$acc end parallel loop
+
+  !$acc kernels loop
+  do i = 1, N
+    a(i) = 3.14
+  end do
+  !$acc end kernels loop
+
+  !$acc serial loop
+  do i = 1, N
+    a(i) = 3.14
+  end do
+  !$acc end serial loop
+
+  !ERROR: DO loop after the PARALLEL LOOP directive must have loop control
+  !$acc parallel loop
+  do
+  end do
+
+  !ERROR: DO loop after the KERNELS LOOP directive must have loop control
+  !$acc kernels loop
+  do
+  end do
+
+  !ERROR: DO loop after the SERIAL LOOP directive must have loop control
+  !$acc serial loop
+  do
+  end do
+
+end program openacc_clause_validity

flang/test/Semantics/acc-clause-validity.f90

@@ -5,6 +5,10 @@
 !   2.5.1 Parallel
 !   2.5.2 Kernels
 !   2.5.3 Serial
+!   2.9 Loop
+!   2.13 Declare
+!   2.14.3 Set
+!   2.14.4 Update
 !   2.15.1 Routine
 !   2.11 Parallel Loop
 !   2.11 Kernels Loop
@@ -162,6 +166,27 @@ program openacc_clause_validity
   end do
   !$acc end serial loop
 
+  !$acc parallel loop
+  do i = 1, N
+    a(i) = 3.14
+  end do
+  !ERROR: Unmatched END KERNELS LOOP directive
+  !$acc end kernels loop
+
+  !$acc kernels loop
+  do i = 1, N
+    a(i) = 3.14
+  end do
+  !ERROR: Unmatched END SERIAL LOOP directive
+  !$acc end serial loop
+
+  !$acc serial loop
+  do i = 1, N
+    a(i) = 3.14
+  end do
+  !ERROR: Unmatched END PARALLEL LOOP directive
+  !$acc end parallel loop
+
  contains
 
    subroutine sub1(a)