[flang] Semantics for !DIR$ IGNORE_TKR

Implement semantics for the IGNORE_TKR directive as it is interpreted
by the PGI / NVFORTRAN compiler.

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

flang/docs/Directives.md

@@ -12,4 +12,20 @@ A list of non-standard directives supported by Flang
 
 * `!dir$ fixed` and `!dir$ free` select Fortran source forms.  Their effect
   persists to the end of the current source file.
-* `!dir$ ignore_tkr (tkr) var-list` omits checks on type, kind, and/or rank.
+* `!dir$ ignore_tkr [[(TKRDMAC)] dummy-arg-name]...` in an interface definition
+  disables some semantic checks at call sites for the actual arguments that
+  correspond to some named dummy arguments (or all of them, by default).
+  The directive allow actual arguments that would otherwise be diagnosed
+  as incompatible in type (T), kind (K), rank (R), CUDA device (D), or
+  managed (M) status.  The letter (A) is a shorthand for all of these,
+  and is the default when no letters appear.  The letter (C) is a legacy
+  no-op.  For example, if one wanted to call a "set all bytes to zero"
+  utility that could be applied to arrays of any type or rank:
+```
+  interface
+    subroutine clear(arr,bytes)
+!dir$ ignore_tkr arr
+      integer(1), intent(out) :: arr(bytes)
+    end
+  end interface
+```

flang/include/flang/Common/Fortran-features.h

@@ -12,6 +12,7 @@
 #include "flang/Common/Fortran.h"
 #include "flang/Common/enum-set.h"
 #include "flang/Common/idioms.h"
+#include <vector>
 
 namespace Fortran::common {
 

flang/include/flang/Common/Fortran.h

@@ -12,9 +12,10 @@
 // Fortran language concepts that are used in many phases are defined
 // once here to avoid redundancy and needless translation.
 
+#include "enum-set.h"
 #include "idioms.h"
 #include <cinttypes>
-#include <vector>
+#include <string>
 
 namespace Fortran::common {
 
@@ -81,5 +82,21 @@ static constexpr int maxRank{15};
 // Fortran names may have up to 63 characters (See Fortran 2018 C601).
 static constexpr int maxNameLen{63};
 
+// !DIR$ IGNORE_TKR [[(letters) name] ... letters
+// "A" expands to all of TKRDM
+ENUM_CLASS(IgnoreTKR,
+    Type, // T - don't check type category
+    Kind, // K - don't check kind
+    Rank, // R - don't check ranks
+    Device, // D - don't check host/device residence
+    Managed, // M - don't check managed storage
+    Contiguous) // C - legacy; disabled NVFORTRAN's convention that leading
+                // dimension of assumed-shape was contiguous
+using IgnoreTKRSet = EnumSet<IgnoreTKR, 8>;
+// IGNORE_TKR(A) = IGNORE_TKR(TKRDM)
+static constexpr IgnoreTKRSet ignoreTKRAll{IgnoreTKR::Type, IgnoreTKR::Kind,
+    IgnoreTKR::Rank, IgnoreTKR::Device, IgnoreTKR::Managed};
+std::string AsFortran(IgnoreTKRSet);
+
 } // namespace Fortran::common
 #endif // FORTRAN_COMMON_FORTRAN_H_

flang/include/flang/Common/enum-class.h

@@ -12,7 +12,7 @@
 //   enum class className { enum1, enum2, ... , enumN };
 // as well as the introspective utilities
 //   static constexpr std::size_t className_enumSize{N};
-//   static inline const std::string &EnumToString(className);
+//   static inline const std::string_view EnumToString(className);
 
 #ifndef FORTRAN_COMMON_ENUM_CLASS_H_
 #define FORTRAN_COMMON_ENUM_CLASS_H_

flang/include/flang/Evaluate/characteristics.h

@@ -219,6 +219,7 @@ struct DummyDataObject {
   std::vector<Expr<SubscriptInteger>> coshape;
   common::Intent intent{common::Intent::Default};
   Attrs attrs;
+  common::IgnoreTKRSet ignoreTKR;
 };
 
 // 15.3.2.3

flang/include/flang/Evaluate/tools.h

@@ -1235,6 +1235,8 @@ const Symbol *FindFunctionResult(const Symbol &);
 // but identical derived types.
 bool AreTkCompatibleTypes(const DeclTypeSpec *x, const DeclTypeSpec *y);
 
+common::IgnoreTKRSet GetIgnoreTKR(const Symbol &);
+
 } // namespace Fortran::semantics
 
 #endif // FORTRAN_EVALUATE_TOOLS_H_

flang/include/flang/Evaluate/type.h

@@ -37,7 +37,12 @@ class DeclTypeSpec;
 class DerivedTypeSpec;
 class ParamValue;
 class Symbol;
+// IsDescriptor() is true when an object requires the use of a descriptor
+// in memory when "at rest".  IsPassedViaDescriptor() is sometimes false
+// when IsDescriptor() is true, including the cases of CHARACTER dummy
+// arguments and explicit & assumed-size dummy arrays.
 bool IsDescriptor(const Symbol &);
+bool IsPassedViaDescriptor(const Symbol &);
 } // namespace Fortran::semantics
 
 namespace Fortran::evaluate {
@@ -190,6 +195,7 @@ class DynamicType {
   // relation.  Kind type parameters must match, but CHARACTER lengths
   // need not do so.
   bool IsTkCompatibleWith(const DynamicType &) const;
+  bool IsTkCompatibleWith(const DynamicType &, common::IgnoreTKRSet) const;
 
   // A stronger compatibility check that does not allow distinct known
   // values for CHARACTER lengths for e.g. MOVE_ALLOC().

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

@@ -60,17 +60,6 @@ template <typename V> void Walk(const format::IntrinsicTypeDataEditDesc &, V &);
 template <typename M> void Walk(format::IntrinsicTypeDataEditDesc &, M &);
 
 // Traversal of needed STL template classes (optional, list, tuple, variant)
-template <typename T, typename V>
-void Walk(const std::optional<T> &x, V &visitor) {
-  if (x) {
-    Walk(*x, visitor);
-  }
-}
-template <typename T, typename M> void Walk(std::optional<T> &x, M &mutator) {
-  if (x) {
-    Walk(*x, mutator);
-  }
-}
 // For most lists, just traverse the elements; but when a list constitutes
 // a Block (i.e., std::list<ExecutionPartConstruct>), also invoke the
 // visitor/mutator on the list itself.
@@ -100,6 +89,17 @@ template <typename M> void Walk(Block &x, M &mutator) {
     mutator.Post(x);
   }
 }
+template <typename T, typename V>
+void Walk(const std::optional<T> &x, V &visitor) {
+  if (x) {
+    Walk(*x, visitor);
+  }
+}
+template <typename T, typename M> void Walk(std::optional<T> &x, M &mutator) {
+  if (x) {
+    Walk(*x, mutator);
+  }
+}
 template <std::size_t I = 0, typename Func, typename T>
 void ForEachInTuple(const T &tuple, Func func) {
   func(std::get<I>(tuple));

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

@@ -3230,14 +3230,14 @@ struct StmtFunctionStmt {
 };
 
 // Compiler directives
-// !DIR$ IGNORE_TKR [ [(tkr...)] name ]...
+// !DIR$ IGNORE_TKR [ [(tkrdmac...)] name ]...
 // !DIR$ LOOP COUNT (n1[, n2]...)
 // !DIR$ name...
 struct CompilerDirective {
   UNION_CLASS_BOILERPLATE(CompilerDirective);
   struct IgnoreTKR {
     TUPLE_CLASS_BOILERPLATE(IgnoreTKR);
-    std::tuple<std::list<const char *>, Name> t;
+    std::tuple<std::optional<std::list<const char *>>, Name> t;
   };
   struct LoopCount {
     WRAPPER_CLASS_BOILERPLATE(LoopCount, std::list<std::uint64_t>);

flang/include/flang/Semantics/symbol.h

@@ -112,6 +112,8 @@ class SubprogramDetails : public WithBindName {
     CHECK(result_ != nullptr);
     result_ = &result;
   }
+  bool defaultIgnoreTKR() const { return defaultIgnoreTKR_; }
+  void set_defaultIgnoreTKR(bool yes) { defaultIgnoreTKR_ = yes; }
 
 private:
   bool isInterface_{false}; // true if this represents an interface-body
@@ -124,6 +126,7 @@ class SubprogramDetails : public WithBindName {
   // interface.  For MODULE PROCEDURE, this is the declared interface if it
   // appeared in an ancestor (sub)module.
   Symbol *moduleInterface_{nullptr};
+  bool defaultIgnoreTKR_{false};
 
   friend llvm::raw_ostream &operator<<(
       llvm::raw_ostream &, const SubprogramDetails &);
@@ -216,6 +219,8 @@ class ObjectEntityDetails : public EntityDetails {
   void set_commonBlock(const Symbol &commonBlock) {
     commonBlock_ = &commonBlock;
   }
+  common::IgnoreTKRSet ignoreTKR() const { return ignoreTKR_; }
+  void set_ignoreTKR(common::IgnoreTKRSet set) { ignoreTKR_ = set; }
   bool IsArray() const { return !shape_.empty(); }
   bool IsCoarray() const { return !coshape_.empty(); }
   bool CanBeAssumedShape() const {
@@ -230,6 +235,7 @@ class ObjectEntityDetails : public EntityDetails {
   const parser::Expr *unanalyzedPDTComponentInit_{nullptr};
   ArraySpec shape_;
   ArraySpec coshape_;
+  common::IgnoreTKRSet ignoreTKR_;
   const Symbol *commonBlock_{nullptr}; // common block this object is in
   friend llvm::raw_ostream &operator<<(
       llvm::raw_ostream &, const ObjectEntityDetails &);

flang/lib/Common/Fortran.cpp

@@ -74,4 +74,27 @@ const char *AsFortran(DefinedIo x) {
   }
 }
 
+std::string AsFortran(IgnoreTKRSet tkr) {
+  std::string result;
+  if (tkr.test(IgnoreTKR::Type)) {
+    result += 'T';
+  }
+  if (tkr.test(IgnoreTKR::Kind)) {
+    result += 'K';
+  }
+  if (tkr.test(IgnoreTKR::Rank)) {
+    result += 'R';
+  }
+  if (tkr.test(IgnoreTKR::Device)) {
+    result += 'D';
+  }
+  if (tkr.test(IgnoreTKR::Managed)) {
+    result += 'M';
+  }
+  if (tkr.test(IgnoreTKR::Contiguous)) {
+    result += 'C';
+  }
+  return result;
+}
+
 } // namespace Fortran::common

flang/lib/Evaluate/characteristics.cpp

@@ -314,6 +314,11 @@ bool DummyDataObject::IsCompatibleWith(
     }
     return false;
   }
+  if (ignoreTKR != actual.ignoreTKR) {
+    if (whyNot) {
+      *whyNot = "incompatible !DIR$ IGNORE_TKR directives";
+    }
+  }
   return true;
 }
 
@@ -331,8 +336,8 @@ static common::Intent GetIntent(const semantics::Attrs &attrs) {
 
 std::optional<DummyDataObject> DummyDataObject::Characterize(
     const semantics::Symbol &symbol, FoldingContext &context) {
-  if (symbol.has<semantics::ObjectEntityDetails>() ||
-      symbol.has<semantics::EntityDetails>()) {
+  if (const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()};
+      object || symbol.has<semantics::EntityDetails>()) {
     if (auto type{TypeAndShape::Characterize(symbol, context)}) {
       std::optional<DummyDataObject> result{std::move(*type)};
       using semantics::Attr;
@@ -348,6 +353,7 @@ std::optional<DummyDataObject> DummyDataObject::Characterize(
               {Attr::TARGET, DummyDataObject::Attr::Target},
           });
       result->intent = GetIntent(symbol.attrs());
+      result->ignoreTKR = GetIgnoreTKR(symbol);
       return result;
     }
   }
@@ -1254,9 +1260,10 @@ class DistinguishUtils {
   bool Distinguishable(const DummyDataObject &, const DummyDataObject &) const;
   bool Distinguishable(const DummyProcedure &, const DummyProcedure &) const;
   bool Distinguishable(const FunctionResult &, const FunctionResult &) const;
-  bool Distinguishable(const TypeAndShape &, const TypeAndShape &) const;
+  bool Distinguishable(
+      const TypeAndShape &, const TypeAndShape &, common::IgnoreTKRSet) const;
   bool IsTkrCompatible(const DummyArgument &, const DummyArgument &) const;
-  bool IsTkrCompatible(const TypeAndShape &, const TypeAndShape &) const;
+  bool IsTkCompatible(const DummyDataObject &, const DummyDataObject &) const;
   const DummyArgument *GetAtEffectivePosition(
       const DummyArguments &, int) const;
   const DummyArgument *GetPassArg(const Procedure &) const;
@@ -1432,7 +1439,7 @@ bool DistinguishUtils::Distinguishable(
 bool DistinguishUtils::Distinguishable(
     const DummyDataObject &x, const DummyDataObject &y) const {
   using Attr = DummyDataObject::Attr;
-  if (Distinguishable(x.type, y.type)) {
+  if (Distinguishable(x.type, y.type, x.ignoreTKR | y.ignoreTKR)) {
     return true;
   } else if (x.attrs.test(Attr::Allocatable) && y.attrs.test(Attr::Pointer) &&
       y.intent != common::Intent::In) {
@@ -1481,7 +1488,8 @@ bool DistinguishUtils::Distinguishable(
   return common::visit(
       common::visitors{
           [&](const TypeAndShape &z) {
-            return Distinguishable(z, std::get<TypeAndShape>(y.u));
+            return Distinguishable(
+                z, std::get<TypeAndShape>(y.u), common::IgnoreTKRSet{});
           },
           [&](const CopyableIndirection<Procedure> &z) {
             return Distinguishable(z.value(),
@@ -1491,24 +1499,39 @@ bool DistinguishUtils::Distinguishable(
       x.u);
 }
 
-bool DistinguishUtils::Distinguishable(
-    const TypeAndShape &x, const TypeAndShape &y) const {
-  return !IsTkrCompatible(x, y) && !IsTkrCompatible(y, x);
+bool DistinguishUtils::Distinguishable(const TypeAndShape &x,
+    const TypeAndShape &y, common::IgnoreTKRSet ignoreTKR) const {
+  if (!x.type().IsTkCompatibleWith(y.type(), ignoreTKR) &&
+      !y.type().IsTkCompatibleWith(x.type(), ignoreTKR)) {
+    return true;
+  }
+  if (ignoreTKR.test(common::IgnoreTKR::Rank)) {
+  } else if (x.attrs().test(TypeAndShape::Attr::AssumedRank) ||
+      y.attrs().test(TypeAndShape::Attr::AssumedRank)) {
+  } else if (x.Rank() != y.Rank()) {
+    return true;
+  }
+  return false;
 }
 
 // Compatibility based on type, kind, and rank
+
 bool DistinguishUtils::IsTkrCompatible(
     const DummyArgument &x, const DummyArgument &y) const {
   const auto *obj1{std::get_if<DummyDataObject>(&x.u)};
   const auto *obj2{std::get_if<DummyDataObject>(&y.u)};
-  return obj1 && obj2 && IsTkrCompatible(obj1->type, obj2->type);
+  return obj1 && obj2 && IsTkCompatible(*obj1, *obj2) &&
+      (obj1->type.Rank() == obj2->type.Rank() ||
+          obj1->type.attrs().test(TypeAndShape::Attr::AssumedRank) ||
+          obj2->type.attrs().test(TypeAndShape::Attr::AssumedRank) ||
+          obj1->ignoreTKR.test(common::IgnoreTKR::Rank) ||
+          obj2->ignoreTKR.test(common::IgnoreTKR::Rank));
 }
-bool DistinguishUtils::IsTkrCompatible(
-    const TypeAndShape &x, const TypeAndShape &y) const {
-  return x.type().IsTkCompatibleWith(y.type()) &&
-      (x.attrs().test(TypeAndShape::Attr::AssumedRank) ||
-          y.attrs().test(TypeAndShape::Attr::AssumedRank) ||
-          x.Rank() == y.Rank());
+
+bool DistinguishUtils::IsTkCompatible(
+    const DummyDataObject &x, const DummyDataObject &y) const {
+  return x.type.type().IsTkCompatibleWith(
+      y.type.type(), x.ignoreTKR | y.ignoreTKR);
 }
 
 // Return the argument at the given index, ignoring the passed arg

flang/lib/Evaluate/tools.cpp

@@ -1657,4 +1657,19 @@ bool AreTkCompatibleTypes(const DeclTypeSpec *x, const DeclTypeSpec *y) {
   return false;
 }
 
+common::IgnoreTKRSet GetIgnoreTKR(const Symbol &symbol) {
+  common::IgnoreTKRSet result;
+  if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
+    result = object->ignoreTKR();
+    if (const Symbol * ownerSymbol{symbol.owner().symbol()}) {
+      if (const auto *ownerSubp{ownerSymbol->detailsIf<SubprogramDetails>()}) {
+        if (ownerSubp->defaultIgnoreTKR()) {
+          result |= common::ignoreTKRAll;
+        }
+      }
+    }
+  }
+  return result;
+}
+
 } // namespace Fortran::semantics