[flang][openacc] Enforce restriction on routine directive and clauses

[clementval]

Summary

This patch add some checks for the restriction on the routine directive
and fix several issue at the same time.

Validity tests have been added in a separate file than acc-clause-validity.f90 since this one
became quite large. I plan to split the larger file once on-going review are done.

[sameeranjoshi]

Thanks for patch.
A few comments below.

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

3823

Sorry I couldn't find where is this defined in standard.
Could you please point that?

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

221

Where is the check for inside subroutine/function as well as inside interface done?
Sorry I might be missing something, but I see you check only for the module scope of the construct.

224

part

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

19

Why isn't it getting resolved though having a resolving function defined above?
Do you think there is a need for a more better resolver, which I tried in
https://reviews.llvm.org/D93051 with the latest diff?

79

Tests for allowedOnceClauses ?

[clementval]

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

3823

3.1 line 2732 and 2733

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

221

The only place where you cannot have routine directive without a name is in the module specification part. So the test here is kind of inverted if you want. Instead of checking where it's allowed, I'm checking where it is not.

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

19

dummy is not defined anywhere and must raise an error here. There is no subroutine/function named dummy so no symbol so the error is triggered. This is the correct behavior. Not all name can be resolved if they really do not exists.

[sameeranjoshi]

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

19

So why is it an internal error, which seems to be a fatal error?
Shouldn't it be something like no declaration found or the normal way we get errors from Fortran part in F18?

[clementval]

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

19

Well this is the Flang error for no symbol found why would you want a different error? I don't get your point here.

[tskeith]

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

19

That message is an internal error, not a user error. An internal error means a bug in the compiler, not in the user's program.

This particular internal error means that we have not resolved dummy to a symbol but we also have not reported any errors to the user indicating what is wrong.

[clementval]

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

19

Alright. I'm gonna issue a proper user error for this case. Thanks for the precision @tskeith

[clementval]

Address review comment + rebase

[clementval]

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

19

@sameeranjoshi User error message is now issued instead of the internal error.

[sameeranjoshi]

LGTM.
Please take care of the remaining nits comments before merging.
Thank you @tskeith for pointers.

[clementval]

Rebase + nit comment

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

224

Good catch! Thx!

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

#define NODE(T1, T2) NODE_NAME(T1::T2, #T2)
   NODE(parser, AccAtomicWrite)
   NODE(parser, AccBeginBlockDirective)
   NODE(parser, AccBeginCombinedDirective)
   NODE(parser, AccBeginLoopDirective)
   NODE(parser, AccBlockDirective)
   NODE(parser, AccClause)
 #define GEN_FLANG_DUMP_PARSE_TREE_CLAUSES
 #include "llvm/Frontend/OpenACC/ACC.cpp.inc"
+  NODE(parser, AccBindClause)
   NODE(parser, AccDefaultClause)
   NODE_ENUM(parser::AccDefaultClause, Arg)
   NODE(parser, AccClauseList)
   NODE(parser, AccCombinedDirective)
   NODE(parser, AccDataModifier)
   NODE_ENUM(parser::AccDataModifier, Modifier)
   NODE(parser, AccDeclarativeDirective)
   NODE(parser, AccEndAtomic)

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

 };
 
 struct AccDeclarativeDirective {
   WRAPPER_CLASS_BOILERPLATE(AccDeclarativeDirective, llvm::acc::Directive);
   CharBlock source;
 };
 
 // OpenACC Clauses
+struct AccBindClause {
+  UNION_CLASS_BOILERPLATE(AccBindClause);
+  std::variant<Name, ScalarDefaultCharExpr> u;
+  CharBlock source;
+};
+
 struct AccDefaultClause {
   ENUM_CLASS(Arg, None, Present)
   WRAPPER_CLASS_BOILERPLATE(AccDefaultClause, Arg);
   CharBlock source;
 };
 
 struct AccDataModifier {
   ENUM_CLASS(Modifier, ReadOnly, Zero)
struct OpenACCCombinedConstruct {
   std::tuple<AccBeginCombinedDirective, std::optional<DoConstruct>,
       std::optional<AccEndCombinedDirective>>
       t;
 };
 
 struct OpenACCDeclarativeConstruct {
   UNION_CLASS_BOILERPLATE(OpenACCDeclarativeConstruct);
   CharBlock source;
-  std::variant<OpenACCStandaloneDeclarativeConstruct> u;
+  std::variant<OpenACCStandaloneDeclarativeConstruct, OpenACCRoutineConstruct>
+      u;
 };
 
 // OpenACC directives enclosing do loop
 struct OpenACCLoopConstruct {
   TUPLE_CLASS_BOILERPLATE(OpenACCLoopConstruct);
   OpenACCLoopConstruct(AccBeginLoopDirective &&a)
       : t({std::move(a), std::nullopt}) {}
   std::tuple<AccBeginLoopDirective, std::optional<DoConstruct>> t;
 };
 
 struct OpenACCStandaloneConstruct {
   TUPLE_CLASS_BOILERPLATE(OpenACCStandaloneConstruct);
   CharBlock source;
   std::tuple<AccStandaloneDirective, AccClauseList> t;
 };
 
 struct OpenACCConstruct {
   UNION_CLASS_BOILERPLATE(OpenACCConstruct);
   std::variant<OpenACCBlockConstruct, OpenACCCombinedConstruct,
-      OpenACCLoopConstruct, OpenACCStandaloneConstruct, OpenACCRoutineConstruct,
-      OpenACCCacheConstruct, OpenACCWaitConstruct, OpenACCAtomicConstruct>
+      OpenACCLoopConstruct, OpenACCStandaloneConstruct, OpenACCCacheConstruct,
+      OpenACCWaitConstruct, OpenACCAtomicConstruct>
       u;
 };
 
 } // namespace Fortran::parser
 #endif // FORTRAN_PARSER_PARSE_TREE_H_

flang/lib/Parser/openacc-parsers.cpp

 constexpr auto endAccLine = space >> endOfLine;
 
 // Basic clauses
 TYPE_PARSER("AUTO" >> construct<AccClause>(construct<AccClause::Auto>()) ||
     "ASYNC" >> construct<AccClause>(construct<AccClause::Async>(
                    maybe(parenthesized(scalarIntExpr)))) ||
     "ATTACH" >> construct<AccClause>(construct<AccClause::Attach>(
                     parenthesized(Parser<AccObjectList>{}))) ||
-    "BIND" >>
-        construct<AccClause>(construct<AccClause::Bind>(parenthesized(name))) ||
+    "BIND" >> construct<AccClause>(
+                  construct<AccClause::Bind>(Parser<AccBindClause>{})) ||
     "CAPTURE" >> construct<AccClause>(construct<AccClause::Capture>()) ||
     "COLLAPSE" >> construct<AccClause>(construct<AccClause::Collapse>(
                       parenthesized(scalarIntConstantExpr))) ||
     ("COPY"_tok || "PRESENT_OR_COPY"_tok || "PCOPY"_tok) >>
         construct<AccClause>(construct<AccClause::Copy>(
             parenthesized(Parser<AccObjectList>{}))) ||
     ("COPYIN"_tok || "PRESENT_OR_COPYIN"_tok || "PCOPYIN"_tok) >>
         construct<AccClause>(construct<AccClause::Copyin>(
first("+" >> pure(AccReductionOperator::Operator::Plus),
         "IAND" >> pure(AccReductionOperator::Operator::Iand),
         "IOR" >> pure(AccReductionOperator::Operator::Ior),
         "IEOR" >> pure(AccReductionOperator::Operator::Ieor),
         ".AND." >> pure(AccReductionOperator::Operator::And),
         ".OR." >> pure(AccReductionOperator::Operator::Or),
         ".EQV." >> pure(AccReductionOperator::Operator::Eqv),
         ".NEQV." >> pure(AccReductionOperator::Operator::Neqv)))))
 
+// 2.15.1 Bind clause
+TYPE_PARSER(sourced(construct<AccBindClause>(parenthesized(name))) ||
+    sourced(construct<AccBindClause>(parenthesized(scalarDefaultCharExpr))))
+
 // 2.5.14 Default clause
 TYPE_PARSER(construct<AccDefaultClause>(
     parenthesized(first("NONE" >> pure(AccDefaultClause::Arg::None),
         "PRESENT" >> pure(AccDefaultClause::Arg::Present)))))
 
 // Modifier for copyin, copyout, cache and create
 TYPE_PARSER(construct<AccDataModifier>(
     first("ZERO:" >> pure(AccDataModifier::Modifier::Zero),

 TYPE_PARSER(construct<OpenACCStandaloneConstruct>(
     sourced(Parser<AccStandaloneDirective>{}), Parser<AccClauseList>{}))
 
 // Standalone declarative constructs
 TYPE_PARSER(construct<OpenACCStandaloneDeclarativeConstruct>(
     sourced(Parser<AccDeclarativeDirective>{}), Parser<AccClauseList>{}))
 
 TYPE_PARSER(
-    startAccLine >> sourced(construct<OpenACCDeclarativeConstruct>(
-                        Parser<OpenACCStandaloneDeclarativeConstruct>{})))
+    startAccLine >> first(sourced(construct<OpenACCDeclarativeConstruct>(
+                              Parser<OpenACCStandaloneDeclarativeConstruct>{})),
+                        sourced(construct<OpenACCDeclarativeConstruct>(
+                            Parser<OpenACCRoutineConstruct>{}))))
 
 // OpenACC constructs
 TYPE_CONTEXT_PARSER("OpenACC construct"_en_US,
     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/unparse.cpp

 #include "llvm/Frontend/OpenACC/ACC.cpp.inc"
   void Unparse(const AccObjectListWithModifier &x) {
     Walk(std::get<std::optional<AccDataModifier>>(x.t), ":");
     Walk(std::get<AccObjectList>(x.t));
   }
   void Unparse(const AccDataModifier::Modifier &x) {
     Word(AccDataModifier::EnumToString(x));
   }
+  void Unparse(const AccBindClause &x) {
+    std::visit(common::visitors{
+                   [&](const Name &y) { Put('('), Walk(y), Put(')'); },
+                   [&](const ScalarDefaultCharExpr &y) {
+                     Put('('), Walk(y), Put(')');
+                   },
+               },
+        x.u);
+  }
   void Unparse(const AccDefaultClause &x) {
     switch (x.v) {
     case AccDefaultClause::Arg::None:
       Put("NONE");
       break;
     case AccDefaultClause::Arg::Present:
       Put("PRESENT");
       break;

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

void AccStructureChecker::Leave(const parser::OpenACCStandaloneConstruct &x) {
   default:
     break;
   }
   dirContext_.pop_back();
 }
 
 void AccStructureChecker::Enter(const parser::OpenACCRoutineConstruct &x) {
   PushContextAndClauseSets(x.source, llvm::acc::Directive::ACCD_routine);
+  const auto &optName{std::get<std::optional<parser::Name>>(x.t)};
+  if (!optName) {
+    const auto &verbatim{std::get<parser::Verbatim>(x.t)};
+    const auto &scope{context_.FindScope(verbatim.source)};
+    const Scope &containingScope{GetProgramUnitContaining(scope)};
+    if (containingScope.kind() == Scope::Kind::Module) {
+      context_.Say(GetContext().directiveSource,
+          "ROUTINE directive without name must appear within the specification "
+          "port of a subroutine or function definition, or within an interface "
+          "body for a subroutine or function in an interface block"_err_en_US);
+    }
+  }
 }
 void AccStructureChecker::Leave(const parser::OpenACCRoutineConstruct &) {
   // Restriction - 2409
   CheckRequireAtLeastOneOf();
   // Restriction - 2407-2408
   CheckOnlyAllowedAfter(llvm::acc::Clause::ACCC_device_type,
       routineOnlyAllowedAfterDeviceTypeClauses);
   dirContext_.pop_back();

flang/lib/Semantics/resolve-directives.cpp

 public:
   explicit AccAttributeVisitor(SemanticsContext &context)
       : DirectiveAttributeVisitor(context) {}
 
   template <typename A> void Walk(const A &x) { parser::Walk(x, *this); }
   template <typename A> bool Pre(const A &) { return true; }
   template <typename A> void Post(const A &) {}
 
-  bool Pre(const parser::SpecificationPart &x) {
-    Walk(std::get<std::list<parser::OpenACCDeclarativeConstruct>>(x.t));
-    return false;
-  }
-
   bool Pre(const parser::OpenACCBlockConstruct &);
   void Post(const parser::OpenACCBlockConstruct &) { PopContext(); }
   bool Pre(const parser::OpenACCCombinedConstruct &);
   void Post(const parser::OpenACCCombinedConstruct &) { PopContext(); }
 
+  bool Pre(const parser::OpenACCDeclarativeConstruct &);
+  void Post(const parser::OpenACCDeclarativeConstruct &) { PopContext(); }
+
+  bool Pre(const parser::OpenACCRoutineConstruct &);
+  bool Pre(const parser::AccBindClause &);
+
   void Post(const parser::AccBeginBlockDirective &) {
     GetContext().withinConstruct = true;
   }
 
   bool Pre(const parser::OpenACCLoopConstruct &);
   void Post(const parser::OpenACCLoopConstruct &) { PopContext(); }
   void Post(const parser::AccLoopDirective &) {
     GetContext().withinConstruct = true;
private:
 
   static constexpr Symbol::Flags accFlagsRequireMark{};
 
   void PrivatizeAssociatedLoopIndex(const parser::OpenACCLoopConstruct &);
   void ResolveAccObjectList(const parser::AccObjectList &, Symbol::Flag);
   void ResolveAccObject(const parser::AccObject &, Symbol::Flag);
   Symbol *ResolveAcc(const parser::Name &, Symbol::Flag, Scope &);
   Symbol *ResolveAcc(Symbol &, Symbol::Flag, Scope &);
+  Symbol *ResolveName(const parser::Name &);
   Symbol *ResolveAccCommonBlockName(const parser::Name *);
   Symbol *DeclareOrMarkOtherAccessEntity(const parser::Name &, Symbol::Flag);
   Symbol *DeclareOrMarkOtherAccessEntity(Symbol &, Symbol::Flag);
   void CheckMultipleAppearances(
       const parser::Name &, const Symbol &, Symbol::Flag);
   void AllowOnlyArrayAndSubArray(const parser::AccObjectList &objectList);
 };
 
case llvm::acc::Directive::ACCD_serial:
     break;
   default:
     break;
   }
   ClearDataSharingAttributeObjects();
   return true;
 }
 
+bool AccAttributeVisitor::Pre(const parser::OpenACCDeclarativeConstruct &x) {
+  if (const auto *declConstruct{
+          std::get_if<parser::OpenACCStandaloneDeclarativeConstruct>(&x.u)}) {
+    const auto &declDir{
+        std::get<parser::AccDeclarativeDirective>(declConstruct->t)};
+    PushContext(declDir.source, llvm::acc::Directive::ACCD_declare);
+  } else if (const auto *routineConstruct{
+                 std::get_if<parser::OpenACCRoutineConstruct>(&x.u)}) {
+    const auto &verbatim{std::get<parser::Verbatim>(routineConstruct->t)};
+    PushContext(verbatim.source, llvm::acc::Directive::ACCD_routine);
+  }
+  ClearDataSharingAttributeObjects();
+  return true;
+}
+
 bool AccAttributeVisitor::Pre(const parser::OpenACCLoopConstruct &x) {
   const auto &beginDir{std::get<parser::AccBeginLoopDirective>(x.t)};
   const auto &loopDir{std::get<parser::AccLoopDirective>(beginDir.t)};
   const auto &clauseList{std::get<parser::AccClauseList>(beginDir.t)};
   if (loopDir.v == llvm::acc::Directive::ACCD_loop) {
     PushContext(loopDir.source, loopDir.v);
   }
   ClearDataSharingAttributeObjects();
case llvm::acc::Directive::ACCD_update:
     break;
   default:
     break;
   }
   ClearDataSharingAttributeObjects();
   return true;
 }
 
+Symbol *AccAttributeVisitor::ResolveName(const parser::Name &name) {
+  Symbol *prev{currScope().FindSymbol(name.source)};
+  if (prev != name.symbol) {
+    name.symbol = prev;
+  }
+  return prev;
+}
+
+bool AccAttributeVisitor::Pre(const parser::OpenACCRoutineConstruct &x) {
+  const auto &optName{std::get<std::optional<parser::Name>>(x.t)};
+  if (optName) {
+    ResolveName(*optName);
+  }
+  return true;
+}
+
+bool AccAttributeVisitor::Pre(const parser::AccBindClause &x) {
+  if (const auto *name{std::get_if<parser::Name>(&x.u)}) {
+    ResolveName(*name);
+  }
+  return true;
+}
+
 bool AccAttributeVisitor::Pre(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) {
   case llvm::acc::Directive::ACCD_kernels_loop:
   case llvm::acc::Directive::ACCD_parallel_loop:
   case llvm::acc::Directive::ACCD_serial_loop:

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

program openacc_clause_validity
   !$acc cache(i)
 
   !ERROR: Only array element or subarray are allowed in CACHE directive
   !$acc cache(t%s)
 
   !ERROR: Only array element or subarray are allowed in CACHE directive
   !$acc cache(/i/)
 
- 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

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

+! RUN: %S/test_errors.sh %s %t %f18 -fopenacc
+
+! Check OpenACC clause validity for the following construct and directive:
+!   2.15.1 routine
+
+module openacc_routine_validity
+  implicit none
+
+  !$acc routine(sub3) seq
+
+  !$acc routine(fct2) vector
+
+  !ERROR: At least one of GANG, SEQ, VECTOR, WORKER clause must appear on the ROUTINE directive
+  !$acc routine(sub3)
+
+  !ERROR: ROUTINE directive without name must appear within the specification port of a subroutine or function definition, or within an interface body for a subroutine or function in an interface block
+  !$acc routine seq
+
+  !ERROR: Internal: no symbol found for 'dummy'
+  !$acc routine(dummy) seq
+
+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
+
+  subroutine sub3(a)
+    real :: a(:)
+  end subroutine sub3
+
+  subroutine sub4(a)
+    real :: a(:)
+    !$acc routine seq
+  end subroutine sub4
+
+  subroutine sub5(a)
+    real :: a(:)
+    !$acc routine(sub5) seq
+  end subroutine sub5
+
+  function fct1(a)
+    integer :: fct1
+    real :: a(:)
+    !$acc routine vector nohost
+  end function fct1
+
+  function fct2(a)
+    integer :: fct2
+    real :: a(:)
+  end function fct2
+
+  function fct3(a)
+    integer :: fct3
+    real :: a(:)
+    !$acc routine seq bind(fct2)
+  end function fct3
+
+  function fct4(a)
+    integer :: fct4
+    real :: a(:)
+    !$acc routine seq bind("_fct4")
+  end function fct4
+
+  subroutine sub6(a)
+    real :: a(:)
+    !ERROR: Internal: no symbol found for 'dummy_sub'
+    !$acc routine seq bind(dummy_sub)
+  end subroutine sub6
+
+end module openacc_routine_validity

llvm/include/llvm/Frontend/OpenACC/ACC.td

 
 // 2.7.11
 def ACCC_Attach : Clause<"attach"> {
   let flangClassValue = "AccObjectList";
 }
 
 // 2.15.1
 def ACCC_Bind : Clause<"bind"> {
-  let flangClassValue = "Name";
+  let flangClassValue = "AccBindClause";
 }
 
 // 2.12
 def ACCC_Capture : Clause<"capture"> {
 }
 
 // 2.9.1
 def ACCC_Collapse : Clause<"collapse"> {