[Flang][OpenACC] Fix for branching out issue in OpenACC parallel construct.

[sameeranjoshi]

Summary

From OpenACC 3.0 Standards document
840 • A program may not branch into or out of an OpenACC parallel construct.
Exits are allowed provided it does not cause an exit outside the parallel region.

Test case exits out of the inner do loop, but it is still inside the parallel region.
Patch tries to extract labels from block attached to a construct,
If the exit is to a label not in the collected list then flags an error.

[clementval]

flang/test/Semantics/acc-branch.f90

176

Can you add a test where the EXIT is out of the parallel construct probably with a label.

[tskeith]

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

54

Why are you converting to a pointer?

I suggest:
if (const auto &name{std::get<std::optional<parser::Name>>(doStmt.statement.t)}) {

63

Why convert to a pointer here?

78

This message needs to be fixed to match the change. RETURN and EXIT are now allowed in some cases so it is not accurate.

188

doConstructNameSet would be a much better name. Then you don't need comments explaining why you chose a confusing name.

189

Can't you do this as part of NoBranchingEnforce? There is a lot of overhead to having another parse tree visitor.

[tskeith]

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

81

"Enclosing block construct" doesn't make sense here. It's not in a block construct.

[clementval]

Pleas add test like the following one where we check the error:

program test
  integer :: i, j
  label1: do i = 1, 10
    !$acc parallel loop
    do j = 1, 10
      if (j == 2) then
        exit label1
      end if
    end do
  end do label1
end program test

[sameeranjoshi]

Worked on review comments.

[clementval]

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

60

I guess they are others construct that can have a label.

[sameeranjoshi]

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

60

Do you mean collecting labels from all the statements in the block?

[clementval]

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

60

I don't have an example right here but it's probable that an exit statement can exit to other constructs label than DoConstruct.

[kiranchandramohan]

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

60

Can you check lib/Semantics/check-do-forall.cpp for similar functionality? Particularly, the following functions.
void DoForallChecker::Enter(const parser::ExitStmt &exitStmt) {

CheckNesting(StmtType::EXIT, common::GetPtrFromOptional(exitStmt.v));

}
void DoForallChecker::CheckNesting

[sameeranjoshi]

Worked on below points:

1. Moved some helper functions to tools.h which can be shared between OpenMP/OpenACC and Fortran constructs.
2. Emit a more better error message.
3. Added more tests.
4. Used ConstructStack to check labels.

[tskeith]

flang/include/flang/Semantics/tools.h

531

Is this used?

534

It looks like the only place that MaybeGetConstructName is used is in MaybeGetNodeName, so how about just doing it inline there? I don't see a benefit of making it part of the API of tools.h.

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

84

Function names should start with a capital letter.

92

That is not a label, it's a construct name. It confuses the user and the code to call things labels that are not.

102

return stmtName.source == constructName.source;

This is probably better done inline.

[sameeranjoshi]

Address review comments.

[sameeranjoshi]

@tskeith are the changes ok?
I have the same patch extended for OpenMP(D88655).

[tskeith]

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

91

I suggest "%s to construct '%s' outside of..."

98

I meant do the comparison in-line, and not define this function. Hiding it in a function makes it more obscure, IMO.

113

Is semantics:: necessary here?

flang/lib/Semantics/check-do-forall.cpp

859

semantics:: ?

917

semantics:: ?

flang/lib/Semantics/tools.cpp

1337

The call to common::GetPtrFromOptional could be moved outside of std::visit so that it doesn't have to be repeated in each lambda.

Even better might be to change the return type to const <std::optional<parser::Name>> &. Is there any reason to convert it to a pointer?

flang/test/Semantics/acc-branch.f90

35

You're still using the word "label" incorrectly here. There are no labels in this test.

[clementval]

@sameeranjoshi Do you have time to address latest review comments?

[sameeranjoshi]

Work on review comments.

[sameeranjoshi]

In D87906#2319931, @clementval wrote:

@sameeranjoshi Do you have time to address latest review comments?

Sorry for holding this for a long, I was trying to solve unknown regressions with respect to check-do-forall.cpp after the current suggested set of changes.

See issue mentioned inline.

flang/lib/Semantics/tools.cpp

1337

My knowledge of modern cpp seemed to pull me back.
I tried various different ways to return const std::optional<parser::Name> &, all resulting in either seg-fault or unknown regressions in fortran loops.
I have managed to do this change using a return-by-value and not return-by-reference.
If these changes still need to be modified, some suggestions on using a return-by-reference would be helpful.

[sameeranjoshi]

flang/test/Semantics/acc-branch.f90

35

Thanks for pointing, it was missed out.

[tskeith]

flang/lib/Semantics/check-do-forall.cpp

921

Can't constructName be nullopt?

flang/lib/Semantics/tools.cpp

1337

You may need to provide return types for the lambdas so that std::visit returns a reference and not a value. Like this:

return std::visit(
    common::visitors{
        [&](const parser::BlockConstruct *blockConstruct)
            -> const std::optional<parser::Name> & {
          return std::get<0>(blockConstruct->t).statement.v;
        },
        [&](const auto *a) -> const std::optional<parser::Name> & {
          return std::get<0>(std::get<0>(a->t).statement.t);
        },
    },
    construct);

[sameeranjoshi]

Address a few more reviews.
Changed to return a reference from MaybeGetNodeName.

[sameeranjoshi]

flang/lib/Semantics/check-do-forall.cpp

921

I don't think we need to handle it here, because I see it's handled inside StmtMatchesConstruct at
https://github.com/llvm/llvm-project/blob/551caec4a8af79483823e2940d40afb4c1df5da1/flang/lib/Semantics/check-do-forall.cpp#L918

I also tried to use the conventional approach of using a guard for std::optional.

if (constructName){
// Accessing the std::optional value by dereferencing it.

}

But I see regressions due to CheckDoConcurrentExit, which seem to have a dependency on the result from StmtMatchesConstruct.
Please correct me if I am wrong here.

flang/lib/Semantics/tools.cpp

1337

Thank a lot!

[tskeith]

flang/lib/Semantics/check-do-forall.cpp

921

It's too late to handle it in StmtMatchesConstruct. It's dereferenced before StmtMatchesConstruct is called. *constructName is undefined if constructName is nullopt.

It would simplify things if that argument were an optional rather than a pointer.

[sameeranjoshi]

Change constructName argument of StmtMatchesConstruct from pointer to std::optional to avoid undefined behaviour.

[tskeith]

flang/lib/Semantics/check-do-forall.cpp

894

The original is better. constructName is checked for null so .value() is unnecessary.

flang/include/flang/Semantics/tools.h

private:
   const char *construct_{nullptr};
 
   parser::MessageFormattedText GetEnclosingConstructMsg();
   void SayWithConstruct(SemanticsContext &context,
       parser::CharBlock stmtLocation, parser::MessageFormattedText &&message,
       parser::CharBlock constructLocation);
 };
 
+template <typename A> const parser::Name *MaybeGetStmtName(const A &a);
+template <typename A> const parser::Name *MaybeGetConstructName(const A &a);
+const parser::Name *MaybeGetConstructName(
+    const parser::BlockConstruct &blockConstruct);
+const parser::Name *MaybeGetNodeName(const ConstructNode &construct);
+
 } // namespace Fortran::semantics
 #endif // FORTRAN_SEMANTICS_TOOLS_H_

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

 //===-- lib/Semantics/check-acc-structure.cpp -----------------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
-
 #include "check-acc-structure.h"
 #include "flang/Parser/parse-tree.h"
 #include "flang/Semantics/tools.h"
 
 #define CHECK_SIMPLE_CLAUSE(X, Y) \
   void AccStructureChecker::Enter(const parser::AccClause::X &) { \
     CheckAllowed(llvm::acc::Clause::Y); \
   }

 
 class NoBranchingEnforce {
 public:
   NoBranchingEnforce(SemanticsContext &context,
       parser::CharBlock sourcePosition, llvm::acc::Directive directive)
       : context_{context}, sourcePosition_{sourcePosition}, currentDirective_{
                                                                 directive} {}
   template <typename T> bool Pre(const T &) { return true; }
   template <typename T> void Post(const T &) {}
 
   template <typename T> bool Pre(const parser::Statement<T> &statement) {
     currentStatementSourcePosition_ = statement.source;
     return true;
   }
 
   void Post(const parser::ReturnStmt &) { emitBranchOutError("RETURN"); }
-  void Post(const parser::ExitStmt &) { emitBranchOutError("EXIT"); }
+  void Post(const parser::ExitStmt &exitStmt) {
+    if (const auto &exitName{exitStmt.v}) {
+      checkConstructNameBranching("EXIT", exitName.value());
+    }
+  }
   void Post(const parser::StopStmt &) { emitBranchOutError("STOP"); }
-
 private:
-  parser::MessageFixedText GetEnclosingMsg() {
-    return "Enclosing block construct"_en_US;
+  parser::MessageFormattedText GetEnclosingMsg() const {
+    return {"Enclosing %s construct"_en_US,
+        parser::ToUpperCaseLetters(
+            llvm::acc::getOpenACCDirectiveName(currentDirective_).str())};
   }
 
-  void emitBranchOutError(const char *stmt) {
+  void emitBranchOutError(const char *stmt) const {
     context_
         .Say(currentStatementSourcePosition_,
             "%s statement is not allowed in a %s construct"_err_en_US, stmt,
             parser::ToUpperCaseLetters(
                 llvm::acc::getOpenACCDirectiveName(currentDirective_).str()))
         .Attach(sourcePosition_, GetEnclosingMsg());
   }
 
+  void emitBranchOutErrorWithLabel(
+      const char *stmt, const parser::Name &toLabel) const {
+    const std::string labelName{toLabel.ToString()};
+    const auto upperCaseConstructName{parser::ToUpperCaseLetters(
+        llvm::acc::getOpenACCDirectiveName(currentDirective_).str())};
+    context_
+        .Say(currentStatementSourcePosition_,
+            "%s to a label '%s' outside of %s construct is not allowed"_err_en_US,
+            stmt, labelName, upperCaseConstructName)
+        .Attach(sourcePosition_, GetEnclosingMsg());
+  }
+
+  bool stmtNameMatchesConstructName(
+      const parser::Name &stmtName, const parser::Name &constructName) const {
+    if ((constructName.ToString().compare(stmtName.ToString()) == 0)) {
+      return true;
+    } else {
+      return false;
+    }
+  }
+  // Current semantic checker is not following OpenACC constructs as they are
+  // not Fortran constructs. Hence the ConstructStack doesn't capture OpenACC
+  // constructs. Apply an inverse way to figure out if a construct-name is
+  // branching out of an OpenACC construct. The control flow goes out of an
+  // OpenACC construct, if a construct-name from statement is found in
+  // ConstructStack.
+  void checkConstructNameBranching(
+      const char *stmt, const parser::Name &stmtName) {
+    const ConstructStack &stack{context_.constructStack()};
+    for (auto iter{stack.cend()}; iter-- != stack.cbegin();) {
+      const ConstructNode &construct{*iter};
+      if (const parser::Name *
+          constructName{semantics::MaybeGetNodeName(construct)}) {
+        if (stmtNameMatchesConstructName(stmtName, *constructName)) {
+          emitBranchOutErrorWithLabel(stmt, stmtName);
+          return;
+        }
+      }
+    }
+  }
+
   SemanticsContext &context_;
   parser::CharBlock currentStatementSourcePosition_;
   parser::CharBlock sourcePosition_;
   llvm::acc::Directive currentDirective_;
 };
 
 void AccStructureChecker::Enter(const parser::AccClause &x) {
   SetContextClause(x);
void AccStructureChecker::Leave(const parser::OpenACCBlockConstruct &x) {
   dirContext_.pop_back();
 }
 
 void AccStructureChecker::CheckNoBranching(const parser::Block &block,
     const llvm::acc::Directive directive,
     const parser::CharBlock &directiveSource) const {
   NoBranchingEnforce noBranchingEnforce{context_, directiveSource, directive};
   parser::Walk(block, noBranchingEnforce);
 }
 
 void AccStructureChecker::Enter(
     const parser::OpenACCStandaloneDeclarativeConstruct &x) {
   const auto &declarativeDir{std::get<parser::AccDeclarativeDirective>(x.t)};
   PushContextAndClauseSets(declarativeDir.source, declarativeDir.v);
 }
 
 void AccStructureChecker::Leave(
     const parser::OpenACCStandaloneDeclarativeConstruct &) {

flang/lib/Semantics/check-do-forall.cpp

 }
 
 static const parser::Name &GetDoVariable(
     const parser::DoConstruct &doConstruct) {
   const Bounds &bounds{GetBounds(doConstruct)};
   return bounds.name.thing;
 }
 
-// Return the (possibly null)  name of the construct
-template <typename A>
-static const parser::Name *MaybeGetConstructName(const A &a) {
-  return common::GetPtrFromOptional(std::get<0>(std::get<0>(a.t).statement.t));
-}
-
 static parser::MessageFixedText GetEnclosingDoMsg() {
   return "Enclosing DO CONCURRENT statement"_en_US;
 }
 
-static const parser::Name *MaybeGetConstructName(
-    const parser::BlockConstruct &blockConstruct) {
-  return common::GetPtrFromOptional(
-      std::get<parser::Statement<parser::BlockStmt>>(blockConstruct.t)
-          .statement.v);
-}
-
 static void SayWithDo(SemanticsContext &context, parser::CharBlock stmtLocation,
     parser::MessageFixedText &&message, parser::CharBlock doLocation) {
   context.Say(stmtLocation, message).Attach(doLocation, GetEnclosingDoMsg());
 }
 
 // 11.1.7.5 - enforce semantics constraints on a DO CONCURRENT loop body
 class DoConcurrentBodyEnforce {
 public:
if (auto *charExpr{
             "ADVANCE specifier is not allowed in DO"
             " CONCURRENT"_err_en_US,
             doConcurrentSourcePosition_);
       }
     }
   }
 
 private:
-  // Return the (possibly null) name of the statement
-  template <typename A>
-  static const parser::Name *MaybeGetStmtName(const A &a) {
-    return common::GetPtrFromOptional(std::get<0>(a.t));
-  }
-
   bool fromScope(const Symbol &symbol, const std::string &moduleName) {
     if (symbol.GetUltimate().owner().IsModule() &&
         symbol.GetUltimate().owner().GetName().value().ToString() ==
             moduleName) {
       return true;
     }
     return false;
   }
void DoForallChecker::Leave(const parser::ForallStmt &stmt) {
   doContext.Check(stmt);
   doContext.DeactivateIndexVars(GetControls(stmt));
 }
 void DoForallChecker::Leave(const parser::ForallAssignmentStmt &stmt) {
   DoContext doContext{context_, IndexVarKind::FORALL};
   doContext.Check(stmt);
 }
 
-// Return the (possibly null) name of the ConstructNode
-static const parser::Name *MaybeGetNodeName(const ConstructNode &construct) {
-  return std::visit(
-      [&](const auto &x) { return MaybeGetConstructName(*x); }, construct);
-}
-
 template <typename A>
 static parser::CharBlock GetConstructPosition(const A &a) {
   return std::get<0>(a.t).source;
 }
 
 static parser::CharBlock GetNodePosition(const ConstructNode &construct) {
   return std::visit(
       [&](const auto &x) { return GetConstructPosition(*x); }, construct);
if (const auto *doNode{
     return *doNode;
   } else {
     return nullptr;
   }
 }
 
 static bool ConstructIsDoConcurrent(const ConstructNode &construct) {
   const parser::DoConstruct *doConstruct{MaybeGetDoConstruct(construct)};
   return doConstruct && doConstruct->IsDoConcurrent();
 }
 
 // Check that CYCLE and EXIT statements do not cause flow of control to
 // leave DO CONCURRENT, CRITICAL, or CHANGE TEAM constructs.
 void DoForallChecker::CheckForBadLeave(
     StmtType stmtType, const ConstructNode &construct) const {
   std::visit(common::visitors{
                  [&](const parser::DoConstruct *doConstructPtr) {

 
 static bool StmtMatchesConstruct(const parser::Name *stmtName,
     StmtType stmtType, const parser::Name *constructName,
     const ConstructNode &construct) {
   bool inDoConstruct{MaybeGetDoConstruct(construct) != nullptr};
   if (!stmtName) {
     return inDoConstruct; // Unlabeled statements match all DO constructs
   } else if (constructName && constructName->source == stmtName->source) {
     return stmtType == StmtType::EXIT || inDoConstruct;
   } else {
     return false;
   }
 }
 
 // C1167 Can't EXIT from a DO CONCURRENT
 void DoForallChecker::CheckDoConcurrentExit(
     StmtType stmtType, const ConstructNode &construct) const {
   if (stmtType == StmtType::EXIT && ConstructIsDoConcurrent(construct)) {
     SayBadLeave(StmtType::EXIT, "DO CONCURRENT", construct);
   }
 }
 
 // Check nesting violations for a CYCLE or EXIT statement.  Loop up the
 // nesting levels looking for a construct that matches the CYCLE or EXIT
 // statment.  At every construct, check for a violation.  If we find a match
 // without finding a violation, the check is complete.
 void DoForallChecker::CheckNesting(
     StmtType stmtType, const parser::Name *stmtName) const {
   const ConstructStack &stack{context_.constructStack()};
   for (auto iter{stack.cend()}; iter-- != stack.cbegin();) {
     const ConstructNode &construct{*iter};
-    const parser::Name *constructName{MaybeGetNodeName(construct)};
+    const parser::Name *constructName{semantics::MaybeGetNodeName(construct)};
     if (StmtMatchesConstruct(stmtName, stmtType, constructName, construct)) {
       CheckDoConcurrentExit(stmtType, construct);
       return; // We got a match, so we're finished checking
     }
     CheckForBadLeave(stmtType, construct);
   }
 
   // We haven't found a match in the enclosing constructs
   if (stmtType == StmtType::EXIT) {
     context_.Say("No matching construct for EXIT statement"_err_en_US);
   } else {
     context_.Say("No matching DO construct for CYCLE statement"_err_en_US);

flang/lib/Semantics/tools.cpp

bool HasAlternateReturns(const Symbol &subprogram) {
   return false;
 }
 
 bool InCommonBlock(const Symbol &symbol) {
   const auto *details{symbol.detailsIf<ObjectEntityDetails>()};
   return details && details->commonBlock();
 }
 
+// Return the (possibly null) name of the statement
+template <typename A> const parser::Name *MaybeGetStmtName(const A &a) {
+  return common::GetPtrFromOptional(std::get<0>(a.t));
+}
+
+// Return the (possibly null)  name of the construct
+template <typename A> const parser::Name *MaybeGetConstructName(const A &a) {
+  return common::GetPtrFromOptional(std::get<0>(std::get<0>(a.t).statement.t));
+}
+
+const parser::Name *MaybeGetConstructName(
+    const parser::BlockConstruct &blockConstruct) {
+  return common::GetPtrFromOptional(
+      std::get<parser::Statement<parser::BlockStmt>>(blockConstruct.t)
+          .statement.v);
+}
+
+// Return the (possibly null) name of the ConstructNode
+const parser::Name *MaybeGetNodeName(const ConstructNode &construct) {
+  return std::visit(
+      [&](const auto &x) { return MaybeGetConstructName(*x); }, construct);
+}
+
 } // namespace Fortran::semantics

flang/test/Semantics/acc-branch.f90

 ! RUN: %S/test_errors.sh %s %t %f18 -fopenacc
 
 ! Check OpenACC restruction in branch in and out of some construct
 !
-
 program openacc_clause_validity
 
   implicit none
 
-  integer :: i
+  integer :: i, j, k
   integer :: N = 256
   real(8) :: a(256)
 
   !$acc parallel
   !$acc loop
   do i = 1, N
     a(i) = 3.14
     !ERROR: RETURN statement is not allowed in a PARALLEL construct
     return
   end do
   !$acc end parallel
 
   !$acc parallel
   !$acc loop
   do i = 1, N
     a(i) = 3.14
     if(i == N-1) THEN
-      !ERROR: EXIT statement is not allowed in a PARALLEL construct
       exit
     end if
   end do
   !$acc end parallel
 
+  ! There are 3 sets:
+  ! label is out of parallel construct, labelled block is attached to an OpenACC parallel construct.
+  ! label is out of parallel construct, labelled block is not attached to an OpenACC parallel construct.
+  ! label is inside OpenACC construct.
+
+  label1: do k=1, N
+  !$acc parallel
+  !$acc loop
+  outer: do i=1, N
+    inner: do j=1, N
+      iflabel: if (j == 2) then
+        ! These are allowed.
+        exit
+        exit inner
+        exit outer
+        !ERROR: EXIT to a label 'label1' outside of PARALLEL construct is not allowed
+        exit label1
+        ! Exit to construct other than loops.
+        exit iflabel
+      end if iflabel
+    end do inner
+  end do outer
+  !$acc end parallel
+  end do label1
+
+  !Attached to parallel.
+  thisblk: BLOCK
+    fortlabel: if (.true.) then
+      label1: do k = 1, N
+        !$acc parallel
+        !ERROR: EXIT to a label 'fortlabel' outside of PARALLEL construct is not allowed
+        exit fortlabel
+        !$acc loop
+          do i = 1, N
+            a(i) = 3.14
+            if(i == N-1) THEN
+              !ERROR: EXIT to a label 'label1' outside of PARALLEL construct is not allowed
+              exit label1
+            end if
+          end do
+
+          loop2: do i = 1, N
+            a(i) = 3.33
+            !ERROR: EXIT to a label 'thisblk' outside of PARALLEL construct is not allowed
+            exit thisblk
+          end do loop2
+        !$acc end parallel
+      end do label1
+    end if fortlabel
+  end BLOCK thisblk
+
+  !label is inside OpenACC construct.
+  !$acc parallel
+  !$acc loop
+  do i = 1, N
+    a(i) = 3.14
+    iflabel: if (i == 2) then
+      ! This is allowed.
+      exit iflabel
+    end if iflabel
+  end do
+  !$acc end parallel
+
   !$acc parallel
   !$acc loop
   do i = 1, N
     a(i) = 3.14
     if(i == N-1) THEN
       !ERROR: STOP statement is not allowed in a PARALLEL construct
       stop 999
     end if
   end do
   !$acc end parallel
 
   !$acc kernels
   do i = 1, N
     a(i) = 3.14
     !ERROR: RETURN statement is not allowed in a KERNELS construct
     return
   end do
   !$acc end kernels
 
   !$acc kernels
   do i = 1, N
     a(i) = 3.14
     if(i == N-1) THEN
-      !ERROR: EXIT statement is not allowed in a KERNELS construct
       exit
     end if
   end do
   !$acc end kernels
 
   !$acc kernels
   do i = 1, N
     a(i) = 3.14
do i = 1, N
     return
   end do
   !$acc end serial
 
   !$acc serial
   do i = 1, N
     a(i) = 3.14
     if(i == N-1) THEN
-      !ERROR: EXIT statement is not allowed in a SERIAL construct
       exit
     end if
   end do
   !$acc end serial
 
+  label2: do k=1, N
+  !$acc serial
+  do i = 1, N
+    iflabel: if (.true.) then
+      print *, "LGTM"
+    a(i) = 3.14
+    if(i == N-1) THEN
+        !ERROR: EXIT to a label 'label2' outside of SERIAL construct is not allowed
+        exit label2
+        exit iflabel
+      end if
+    end if iflabel
+    end do
+  !$acc end serial
+  end do label2
+
   !$acc serial
   do i = 1, N
     a(i) = 3.14
     if(i == N-1) THEN
       !ERROR: STOP statement is not allowed in a SERIAL construct
       stop 999
     end if
   end do
   !$acc end serial
 
 end program openacc_clause_validity