[flang][openacc] Keep routine information in the module file

[clementval]

Summary

This patch propagates the acc routine information
to the module file so they can be used by the caller.

[razvanlupusoru]

Looks great. Nice job capturing this information - also especially sub10 which has the acc routine in a separate spot. Great work!

[kiranchandramohan]

Not a review comment. FYI @skatrak to check whether there is anything similar to the work that is being done for the openmp requires directive.
https://reviews.llvm.org/D157983
https://reviews.llvm.org/D158168

flang/include/flang/Semantics/symbol.h

public:
   void set_bindName(std::string &&name) { bindName_ = std::move(name); }
   void set_isExplicitBindName(bool yes) { isExplicitBindName_ = yes; }
 
 private:
   std::optional<std::string> bindName_;
   bool isExplicitBindName_{false};
 };
 
+class OpenACCRoutineInfo {
+public:
+  bool isSeq() const { return isSeq_; }
+  void set_isSeq(bool value = true) { isSeq_ = value; }
+  bool isVector() const { return isVector_; }
+  void set_isVector(bool value = true) { isVector_ = value; }
+  bool isWorker() const { return isWorker_; }
+  void set_isWorker(bool value = true) { isWorker_ = value; }
+  bool isGang() const { return isGang_; }
+  void set_isGang(bool value = true) { isGang_ = value; }
+  unsigned gangDim() const { return gangDim_; }
+  void set_gangDim(unsigned value) { gangDim_ = value; }
+  bool isNohost() const { return isNohost_; }
+  void set_isNohost(bool value = true) { isNohost_ = value; }
+  const std::string *bindName() const {
+    return bindName_ ? &*bindName_ : nullptr;
+  }
+  void set_bindName(std::string &&name) { bindName_ = std::move(name); }
+
+private:
+  bool isSeq_{false};
+  bool isVector_{false};
+  bool isWorker_{false};
+  bool isGang_{false};
+  unsigned gangDim_{0};
+  bool isNohost_{false};
+  std::optional<std::string> bindName_;
+};
+
 // A subroutine or function definition, or a subprogram interface defined
 // in an INTERFACE block as part of the definition of a dummy procedure
 // or a procedure pointer (with just POINTER).
 class SubprogramDetails : public WithBindName {
 public:
   bool isFunction() const { return result_ != nullptr; }
   bool isInterface() const { return isInterface_; }
   void set_isInterface(bool value = true) { isInterface_ = value; }
public:
   }
   std::vector<std::int64_t> &cudaClusterDims() { return cudaClusterDims_; }
   const std::vector<std::int64_t> &cudaClusterDims() const {
     return cudaClusterDims_;
   }
   void set_cudaClusterDims(std::vector<std::int64_t> &&x) {
     cudaClusterDims_ = std::move(x);
   }
+  const std::vector<OpenACCRoutineInfo> &openACCRoutineInfos() const {
+    return openACCRoutineInfos_;
+  }
+  void add_openACCRoutineInfo(OpenACCRoutineInfo info) {
+    openACCRoutineInfos_.push_back(info);
+  }
 
 private:
   bool isInterface_{false}; // true if this represents an interface-body
   bool isDummy_{false}; // true when interface of dummy procedure
   std::vector<Symbol *> dummyArgs_; // nullptr -> alternate return indicator
   Symbol *result_{nullptr};
   Scope *entryScope_{nullptr}; // if ENTRY, points to subprogram's scope
   MaybeExpr stmtFunction_;
   // For MODULE FUNCTION or SUBROUTINE, this is the symbol of its declared
   // interface.  For MODULE PROCEDURE, this is the declared interface if it
   // appeared in an ancestor (sub)module.
   Symbol *moduleInterface_{nullptr};
   bool defaultIgnoreTKR_{false};
   // CUDA ATTRIBUTES(...) from subroutine/function prefix
   std::optional<common::CUDASubprogramAttrs> cudaSubprogramAttrs_;
   // CUDA LAUNCH_BOUNDS(...) & CLUSTER_DIMS(...) from prefix
   std::vector<std::int64_t> cudaLaunchBounds_, cudaClusterDims_;
+  // OpenACC routine information
+  std::vector<OpenACCRoutineInfo> openACCRoutineInfos_;
 
   friend llvm::raw_ostream &operator<<(
       llvm::raw_ostream &, const SubprogramDetails &);
 };
 
 // For SubprogramNameDetails, the kind indicates whether it is the name
 // of a module subprogram or an internal subprogram or ENTRY.
 ENUM_CLASS(SubprogramKind, Module, Internal)

flang/include/flang/Semantics/tools.h

 inline const parser::Name *getDesignatorNameIfDataRef(
     const parser::Designator &designator) {
   const auto *dataRef{std::get_if<parser::DataRef>(&designator.u)};
   return dataRef ? std::get_if<parser::Name>(&dataRef->u) : nullptr;
 }
 
 bool CouldBeDataPointerValuedFunction(const Symbol *);
 
+template <typename R, typename T>
+std::optional<R> GetConstExpr(
+    Fortran::semantics::SemanticsContext &semanticsContext, const T &x) {
+  using DefaultCharConstantType = Fortran::evaluate::Ascii;
+  if (const auto *expr{Fortran::semantics::GetExpr(semanticsContext, x)}) {
+    const auto foldExpr{Fortran::evaluate::Fold(
+        semanticsContext.foldingContext(), Fortran::common::Clone(*expr))};
+    if constexpr (std::is_same_v<R, std::string>) {
+      return Fortran::evaluate::GetScalarConstantValue<DefaultCharConstantType>(
+          foldExpr);
+    }
+  }
+  return std::nullopt;
+}
+
 } // namespace Fortran::semantics
 #endif // FORTRAN_SEMANTICS_TOOLS_H_

flang/lib/Lower/OpenACC.cpp

if (funcOp)
                            directiveLocation, accClauseList);
     else if (moduleOp)
       genDeclareInModule(converter, moduleOp, accClauseList);
     return;
   }
   llvm_unreachable("unsupported declarative directive");
 }
 
-template <typename R, typename T>
-std::optional<R>
-GetConstExpr(Fortran::semantics::SemanticsContext &semanticsContext,
-             const T &x) {
-  using DefaultCharConstantType = Fortran::evaluate::Ascii;
-  if (const auto *expr{Fortran::semantics::GetExpr(semanticsContext, x)}) {
-    const auto foldExpr{Fortran::evaluate::Fold(
-        semanticsContext.foldingContext(), Fortran::common::Clone(*expr))};
-    if constexpr (std::is_same_v<R, std::string>) {
-      return Fortran::evaluate::GetScalarConstantValue<DefaultCharConstantType>(
-          foldExpr);
-    }
-  }
-  return std::nullopt;
-}
-
 static void attachRoutineInfo(mlir::func::FuncOp func,
                               mlir::SymbolRefAttr routineAttr) {
   llvm::SmallVector<mlir::SymbolRefAttr> routines;
   if (func.getOperation()->hasAttr(mlir::acc::getRoutineInfoAttrName())) {
     auto routineInfo =
         func.getOperation()->getAttrOfType<mlir::acc::RoutineInfoAttr>(
             mlir::acc::getRoutineInfoAttrName());
     routines.append(routineInfo.getAccRoutines().begin(),
if (std::get_if<Fortran::parser::AccClause::Seq>(&clause.u)) {
       if (const auto *name =
               std::get_if<Fortran::parser::Name>(&bindClause->v.u)) {
         routineOp.setBindName(
             builder.getStringAttr(converter.mangleName(*name->symbol)));
       } else if (const auto charExpr =
                      std::get_if<Fortran::parser::ScalarDefaultCharExpr>(
                          &bindClause->v.u)) {
         const std::optional<std::string> bindName =
-            GetConstExpr<std::string>(semanticsContext, *charExpr);
+            Fortran::semantics::GetConstExpr<std::string>(semanticsContext,
+                                                          *charExpr);
         if (!bindName)
           routineOp.emitError("Could not retrieve the bind name");
         routineOp.setBindName(builder.getStringAttr(*bindName));
       }
     }
   }
 
   if (funcOp)

flang/lib/Semantics/mod-file.cpp

void ModFileWriter::PutDECStructure(
   PutComponents(typeSymbol);
   decls_ << "end structure\n";
 }
 
 // Attributes that may be in a subprogram prefix
 static const Attrs subprogramPrefixAttrs{Attr::ELEMENTAL, Attr::IMPURE,
     Attr::MODULE, Attr::NON_RECURSIVE, Attr::PURE, Attr::RECURSIVE};
 
+static void PutOpenACCRoutineInfo(
+    llvm::raw_ostream &os, const SubprogramDetails &details) {
+  for (auto info : details.openACCRoutineInfos()) {
+    os << "!$acc routine";
+    if (info.isSeq()) {
+      os << " seq";
+    }
+    if (info.isGang()) {
+      os << " gang";
+      if (info.gangDim() > 0) {
+        os << "(dim: " << info.gangDim() << ")";
+      }
+    }
+    if (info.isVector()) {
+      os << " vector";
+    }
+    if (info.isWorker()) {
+      os << " worker";
+    }
+    if (info.isNohost()) {
+      os << " nohost";
+    }
+    if (info.bindName()) {
+      os << " bind(" << *info.bindName() << ")";
+    }
+    os << "\n";
+  }
+}
+
 void ModFileWriter::PutSubprogram(const Symbol &symbol) {
   auto &details{symbol.get<SubprogramDetails>()};
   if (const Symbol * interface{details.moduleInterface()}) {
     const Scope *module{FindModuleContaining(interface->owner())};
     if (module && module != &symbol.owner()) {
       // Interface is in ancestor module
     } else {
       PutSubprogram(*interface);
for (const Symbol &need : collector.symbols()) {
     writer.PutSymbol(typeBindings, need);
   }
   CHECK(typeBindings.str().empty());
   os << writer.uses_.str();
   for (const SourceName &import : collector.imports()) {
     decls_ << "import::" << import << "\n";
   }
   os << writer.decls_.str();
+  PutOpenACCRoutineInfo(os, details);
   os << "end\n";
   if (isInterface) {
     os << "end interface\n";
   }
 }
 
 static bool IsIntrinsicOp(const Symbol &symbol) {
   if (const auto *details{symbol.GetUltimate().detailsIf<GenericDetails>()}) {

flang/lib/Semantics/resolve-directives.cpp

 #include "flang/Evaluate/fold.h"
 #include "flang/Evaluate/type.h"
 #include "flang/Parser/parse-tree-visitor.h"
 #include "flang/Parser/parse-tree.h"
 #include "flang/Parser/tools.h"
 #include "flang/Semantics/expression.h"
 #include <list>
 #include <map>
+#include <sstream>
 
 namespace Fortran::semantics {
 
 template <typename T> class DirectiveAttributeVisitor {
 public:
   explicit DirectiveAttributeVisitor(SemanticsContext &context)
       : context_{context} {}
 
private:
   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);
   void DoNotAllowAssumedSizedArray(const parser::AccObjectList &objectList);
   void EnsureAllocatableOrPointer(
       const llvm::acc::Clause clause, const parser::AccObjectList &objectList);
+  void AddRoutineInfoToSymbol(
+      Symbol &, const parser::OpenACCRoutineConstruct &);
 };
 
 // Data-sharing and Data-mapping attributes for data-refs in OpenMP construct
 class OmpAttributeVisitor : DirectiveAttributeVisitor<llvm::omp::Directive> {
 public:
   explicit OmpAttributeVisitor(SemanticsContext &context)
       : DirectiveAttributeVisitor(context) {}
 
if (!prev && parentScope) {
     prev = currScope().parent().FindSymbol(name.source);
   }
   if (prev != name.symbol) {
     name.symbol = prev;
   }
   return prev;
 }
 
+template <typename T>
+common::IfNoLvalue<T, T> FoldExpr(
+    evaluate::FoldingContext &foldingContext, T &&expr) {
+  return evaluate::Fold(foldingContext, std::move(expr));
+}
+
+template <typename T>
+MaybeExpr EvaluateExpr(
+    Fortran::semantics::SemanticsContext &semanticsContext, const T &expr) {
+  return FoldExpr(
+      semanticsContext.foldingContext(), AnalyzeExpr(semanticsContext, expr));
+}
+
+void AccAttributeVisitor::AddRoutineInfoToSymbol(
+    Symbol &symbol, const parser::OpenACCRoutineConstruct &x) {
+  if (symbol.has<SubprogramDetails>()) {
+    Fortran::semantics::OpenACCRoutineInfo info;
+    const auto &clauses = std::get<Fortran::parser::AccClauseList>(x.t);
+    for (const Fortran::parser::AccClause &clause : clauses.v) {
+      if (std::get_if<Fortran::parser::AccClause::Seq>(&clause.u)) {
+        info.set_isSeq();
+      } else if (const auto *gangClause =
+                     std::get_if<Fortran::parser::AccClause::Gang>(&clause.u)) {
+        info.set_isGang();
+        if (gangClause->v) {
+          const Fortran::parser::AccGangArgList &x = *gangClause->v;
+          for (const Fortran::parser::AccGangArg &gangArg : x.v) {
+            if (const auto *dim =
+                    std::get_if<Fortran::parser::AccGangArg::Dim>(&gangArg.u)) {
+              if (const auto v{EvaluateInt64(context_, dim->v)}) {
+                info.set_gangDim(*v);
+              }
+            }
+          }
+        }
+      } else if (std::get_if<Fortran::parser::AccClause::Vector>(&clause.u)) {
+        info.set_isVector();
+      } else if (std::get_if<Fortran::parser::AccClause::Worker>(&clause.u)) {
+        info.set_isWorker();
+      } else if (std::get_if<Fortran::parser::AccClause::Nohost>(&clause.u)) {
+        info.set_isNohost();
+      } else if (const auto *bindClause =
+                     std::get_if<Fortran::parser::AccClause::Bind>(&clause.u)) {
+        if (const auto *name =
+                std::get_if<Fortran::parser::Name>(&bindClause->v.u)) {
+          if (Symbol *sym = ResolveName(*name, true)) {
+            info.set_bindName(sym->name().ToString());
+          } else {
+            context_.Say((*name).source,
+                "No function or subroutine declared for '%s'"_err_en_US,
+                (*name).source);
+          }
+        } else if (const auto charExpr =
+                       std::get_if<Fortran::parser::ScalarDefaultCharExpr>(
+                           &bindClause->v.u)) {
+          auto *charConst =
+              Fortran::parser::Unwrap<Fortran::parser::CharLiteralConstant>(
+                  *charExpr);
+          std::string str{std::get<std::string>(charConst->t)};
+          std::stringstream bindName;
+          bindName << "\"" << str << "\"";
+          info.set_bindName(std::move(bindName.str()));
+        }
+      }
+    }
+    symbol.get<SubprogramDetails>().add_openACCRoutineInfo(info);
+  }
+}
+
 bool AccAttributeVisitor::Pre(const parser::OpenACCRoutineConstruct &x) {
   const auto &optName{std::get<std::optional<parser::Name>>(x.t)};
   if (optName) {
-    if (!ResolveName(*optName, true)) {
+    if (Symbol *sym = ResolveName(*optName, true)) {
+      Symbol &ultimate{sym->GetUltimate()};
+      AddRoutineInfoToSymbol(ultimate, x);
+    } else {
       context_.Say((*optName).source,
           "No function or subroutine declared for '%s'"_err_en_US,
           (*optName).source);
     }
+  } else {
+    AddRoutineInfoToSymbol(*currScope().symbol(), x);
   }
   return true;
 }
 
 bool AccAttributeVisitor::Pre(const parser::AccBindClause &x) {
   if (const auto *name{std::get_if<parser::Name>(&x.u)}) {
     if (!ResolveName(*name, true)) {
       context_.Say(name->source,

flang/test/Semantics/OpenACC/acc-module.f90

module acc_mod
   real :: data_copyinro(10)
   !$acc declare copyin(readonly: data_copyinro)
 
   real :: data_device_resident(20)
   !$acc declare device_resident(data_device_resident)
 
   integer :: data_link(50)
   !$acc declare link(data_link)
+
+  !$acc routine(sub10) seq
+
+contains
+  subroutine sub1()
+    !$acc routine
+  end subroutine
+
+  subroutine sub2()
+    !$acc routine seq
+  end subroutine
+
+  subroutine sub3()
+    !$acc routine gang
+  end subroutine
+
+  subroutine sub4()
+    !$acc routine vector
+  end subroutine
+
+  subroutine sub5()
+    !$acc routine worker
+  end subroutine
+
+  subroutine sub6()
+    !$acc routine gang(dim:2)
+  end subroutine
+
+  subroutine sub7()
+    !$acc routine bind("sub7_")
+  end subroutine
+
+  subroutine sub8()
+    !$acc routine bind(sub7)
+  end subroutine
+
+  subroutine sub9()
+    !$acc routine vector
+    !$acc routine seq bind(sub7)
+    !$acc routine gang bind(sub8)
+  end subroutine
+
+  subroutine sub10()
+  end subroutine
+
 end module
 
 !Expect: acc_mod.mod
 ! module acc_mod
 ! real(4)::data_create(1_8:100_8)
 ! !$acc declare create(data_create)
 ! real(4)::data_copyin(1_8:10_8)
 ! !$acc declare copyin(data_copyin)
 ! real(4)::data_copyinro(1_8:10_8)
 ! !$acc declare copyin(readonly: data_copyinro)
 ! real(4)::data_device_resident(1_8:20_8)
 ! !$acc declare device_resident(data_device_resident)
 ! integer(4)::data_link(1_8:50_8)
 ! !$acc declare link(data_link)
+! contains
+! subroutine sub1()
+! !$acc routine
+! end
+! subroutine sub2()
+! !$acc routine seq
+! end
+! subroutine sub3()
+! !$acc routine gang
+! end
+! subroutine sub4()
+! !$acc routine vector
+! end
+! subroutine sub5()
+! !$acc routine worker
+! end
+! subroutine sub6()
+! !$acc routine gang(dim:2)
+! end
+! subroutine sub7()
+! !$acc routine bind("sub7_")
+! end
+! subroutine sub8()
+! !$acc routine bind(sub7)
+! end
+! subroutine sub9()
+! !$acc routine vector
+! !$acc routine seq bind(sub7)
+! !$acc routine gang bind(sub8)
+! end
+! subroutine sub10()
+! !$acc routine seq
+! end
 ! end