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

[clementval]

Summary

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.

[clementval]

As discussed in D84195 with @ichoyjx.

[clementval]

Remove pre-fir tree AccEndCombinedDirective since it is not necessary

[kiranchandramohan]

flang/lib/Semantics/canonicalize-acc.cpp

89

#just-asking: Is it possible to combine this with RewriteOpenACCLoopConstruct and the Canonicalisation for OpenMP loop?

[clementval]

flang/lib/Semantics/canonicalize-acc.cpp

89

I guess if we start at a higher level of construct like OpenACCConstruct we can merge the loop and combined construct rewrite. To reduce the code duplication between canonicalization we can extract the rewriting code in a templated function but I'm assuming we still need the rewrite functions to call the templated function then. I'll try to have a look at it this week-end if I find time. Always good if we can reduce the amount of code that is duplicated.

[klausler]

flang/lib/Parser/program-parsers.cpp

79–82

Can an OpenACC end directive really be the first statement in the executable part?

[clementval]

flang/lib/Parser/program-parsers.cpp

79–82

Only if the user makes a big mistake. I guess same with ompEndLoopDirective. I'm fine to remove it. It was to do as omp loop was done.

[clementval]

flang/lib/Parser/program-parsers.cpp

79–82

@klausler So should we remove both ompEndLoopDirective and accEndCombinedDirective ?

[klausler]

flang/lib/Parser/program-parsers.cpp

79–82

Please do so; thanks.

79–82

Yes, please.

[clementval]

Address review comment

[clementval]

@klausler The patch is updated.

flang/lib/Parser/program-parsers.cpp

79–82

Removed in the updated patch

[klausler]

Thanks!

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

 struct CompilerDirective;
 struct BasedPointerStmt;
 struct StructureDef;
 struct ArithmeticIfStmt;
 struct AssignStmt;
 struct AssignedGotoStmt;
 struct PauseStmt;
 struct OpenACCConstruct;
+struct AccEndCombinedDirective;
 struct OpenACCDeclarativeConstruct;
 struct OpenMPConstruct;
 struct OpenMPDeclarativeConstruct;
 struct OmpEndLoopDirective;
 
 // Cooked character stream locations
 using Location = const char *;
 
std::variant<Statement<ActionStmt>, common::Indirection<AssociateConstruct>,
       Statement<common::Indirection<LabelDoStmt>>,
       Statement<common::Indirection<EndDoStmt>>,
       common::Indirection<DoConstruct>, common::Indirection<IfConstruct>,
       common::Indirection<SelectRankConstruct>,
       common::Indirection<SelectTypeConstruct>,
       common::Indirection<WhereConstruct>, common::Indirection<ForallConstruct>,
       common::Indirection<CompilerDirective>,
       common::Indirection<OpenACCConstruct>,
+      common::Indirection<AccEndCombinedDirective>,
       common::Indirection<OpenMPConstruct>,
       common::Indirection<OmpEndLoopDirective>>
       u;
 };
 
 // R510 execution-part-construct ->
 //        executable-construct | format-stmt | entry-stmt | data-stmt
 // Extension (PGI/Intel): also accept NAMELIST in execution part

 struct OpenACCStandaloneDeclarativeConstruct {
   TUPLE_CLASS_BOILERPLATE(OpenACCStandaloneDeclarativeConstruct);
   CharBlock source;
   std::tuple<AccDeclarativeDirective, AccClauseList> t;
 };
 
 struct AccBeginCombinedDirective {
   TUPLE_CLASS_BOILERPLATE(AccBeginCombinedDirective);
+  CharBlock source;
   std::tuple<AccCombinedDirective, AccClauseList> t;
 };
 
 struct AccEndCombinedDirective {
   WRAPPER_CLASS_BOILERPLATE(AccEndCombinedDirective, AccCombinedDirective);
   CharBlock source;
 };
 
 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;
 };
 
 struct OpenACCDeclarativeConstruct {
   UNION_CLASS_BOILERPLATE(OpenACCDeclarativeConstruct);
   CharBlock source;
   std::variant<OpenACCStandaloneDeclarativeConstruct> u;

flang/lib/Parser/executable-parsers.cpp

first(construct<ExecutableConstruct>(CapturedLabelDoStmt{}),
         construct<ExecutableConstruct>(indirect(Parser<ChangeTeamConstruct>{})),
         construct<ExecutableConstruct>(indirect(Parser<CriticalConstruct>{})),
         construct<ExecutableConstruct>(indirect(Parser<IfConstruct>{})),
         construct<ExecutableConstruct>(indirect(Parser<SelectRankConstruct>{})),
         construct<ExecutableConstruct>(indirect(Parser<SelectTypeConstruct>{})),
         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 ->
 //        executable-construct | format-stmt | entry-stmt | data-stmt
 // Extension (PGI/Intel): also accept NAMELIST in execution part
 constexpr auto obsoleteExecutionPartConstruct{recovery(ignoredStatementPrefix >>
         fail<ExecutionPartConstruct>(
             "obsolete legacy extension is not supported"_err_en_US),

flang/lib/Parser/openacc-parsers.cpp

TYPE_PARSER(sourced(construct<OpenACCRoutineConstruct>(verbatim("ROUTINE"_tok),
     maybe(parenthesized(name)), Parser<AccClauseList>{})))
 
 // 2.10 Cache directive
 TYPE_PARSER(sourced(
     construct<OpenACCCacheConstruct>(sourced(construct<Verbatim>("CACHE"_tok)),
         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))
 
 TYPE_PARSER("ATOMIC" >>
     construct<AccAtomicRead>(verbatim("READ"_tok) / endAccLine,
         statement(assignmentStmt), maybe(Parser<AccEndAtomic>{} / endAccLine)))
 
 TYPE_PARSER("ATOMIC" >>
startAccLine >>
         first(construct<OpenACCConstruct>(Parser<OpenACCBlockConstruct>{}),
             construct<OpenACCConstruct>(Parser<OpenACCCombinedConstruct>{}),
             construct<OpenACCConstruct>(Parser<OpenACCLoopConstruct>{}),
             construct<OpenACCConstruct>(Parser<OpenACCStandaloneConstruct>{}),
             construct<OpenACCConstruct>(Parser<OpenACCRoutineConstruct>{}),
             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

 //        entry-stmt | stmt-function-stmt
 // N.B. These parsers incorporate recognition of some other statements that
 // may have been misplaced in the sequence of statements that are acceptable
 // as a specification part in order to improve error recovery.
 // Also note that many instances of specification-part in the standard grammar
 // 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,
+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>{} >>
         fail<DeclarationConstruct>("misplaced USE statement"_err_en_US) ||
     Parser<ImportStmt>{} >>
         fail<DeclarationConstruct>(
             "IMPORT statements must follow any USE statements and precede all other declarations"_err_en_US) ||
     Parser<ImplicitStmt>{} >>

flang/lib/Parser/type-parsers.h

 constexpr Parser<SubroutineSubprogram> subroutineSubprogram; // R1534
 constexpr Parser<SubroutineStmt> subroutineStmt; // R1535
 constexpr Parser<DummyArg> dummyArg; // R1536
 constexpr Parser<EndSubroutineStmt> endSubroutineStmt; // R1537
 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;
 constexpr Parser<OmpEndLoopDirective> ompEndLoopDirective;
 } // namespace Fortran::parser
 #endif // FORTRAN_PARSER_TYPE_PARSERS_H_

flang/lib/Parser/unparse.cpp

void Unparse(const OpenACCStandaloneDeclarativeConstruct &x) {
     EndOpenACC();
   }
   void Unparse(const OpenACCCombinedConstruct &x) {
     BeginOpenACC();
     Word("!$ACC ");
     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();
   }
   void Unparse(const OpenACCRoutineConstruct &x) {
     BeginOpenACC();
     Word("!$ACC ROUTINE");
     Walk("(", std::get<std::optional<Name>>(x.t), ")");
     Walk(std::get<AccClauseList>(x.t));

flang/lib/Semantics/canonicalize-acc.cpp

 #include "flang/Semantics/tools.h"
 
 // After Loop Canonicalization, rewrite OpenACC parse tree to make OpenACC
 // Constructs more structured which provide explicit scopes for later
 // structural checks and semantic analysis.
 //   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;
 
 class CanonicalizationOfAcc {
 public:
   template <typename T> bool Pre(T &) { return true; }
   template <typename T> void Post(T &) {}
   CanonicalizationOfAcc(parser::Messages &messages) : messages_{messages} {}
 
   void Post(parser::Block &block) {
     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
   }
 
 private:
   void RewriteOpenACCLoopConstruct(parser::OpenACCLoopConstruct &x,
       parser::Block &block, parser::Block::iterator it) {
     // Check the sequence of DoConstruct in the same iteration
if (++nextIt != block.end()) {
         return; // found do-loop
       }
     }
     messages_.Say(dir.source,
         "A DO loop must follow the %s directive"_err_en_US,
         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_;
 };
 
 bool CanonicalizeAcc(parser::Messages &messages, parser::Program &program) {
   CanonicalizationOfAcc acc{messages};
   Walk(program, acc);
   return !messages.AnyFatalError();
 }
 } // namespace Fortran::semantics

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

 void AccStructureChecker::Leave(
     const parser::OpenACCStandaloneDeclarativeConstruct &) {
   // Restriction - 2075
   CheckAtLeastOneClause();
   accContext_.pop_back();
 }
 
 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);
 }
 
 void AccStructureChecker::Leave(const parser::OpenACCCombinedConstruct &x) {
   const auto &beginBlockDir{std::get<parser::AccBeginCombinedDirective>(x.t)};
   const auto &combinedDir{
       std::get<parser::AccCombinedDirective>(beginBlockDir.t)};
   switch (combinedDir.v) {

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

subroutine foo()
   end do
   !$acc end parallel
   ! CHECK-NEXT: <<End OpenACCConstruct>>
   ! CHECK-NEXT: <<End OpenACCConstruct>>
   ! CHECK-NEXT: ContinueStmt
 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

+! 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

 ! RUN: %S/test_errors.sh %s %t %f18 -fopenacc
 
 ! Check OpenACC clause validity for the following construct and directive:
 !   2.6.5 Data
 !   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
 !   2.11 Serial Loop
 
 program openacc_clause_validity
 
   implicit none
program openacc_clause_validity
 
   !ERROR: Clause IF is not allowed after clause DEVICE_TYPE on the SERIAL LOOP directive
   !$acc serial loop device_type(*) if(.TRUE.)
   do i = 1, N
     a(i) = 3.14
   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)
      real :: a(:)
      !ERROR: At least one of GANG, SEQ, VECTOR, WORKER clause must appear on the ROUTINE directive
      !$acc routine
    end subroutine sub1
 
    subroutine sub2(a)
      real :: a(:)
      !ERROR: Clause NOHOST is not allowed after clause DEVICE_TYPE on the ROUTINE directive
      !$acc routine seq device_type(*) nohost
    end subroutine sub2
 
 end program openacc_clause_validity