[flang] Consolidate copy-in/copy-out determination in evaluate framework

flang/include/flang/Evaluate/characteristics.h

@@ -203,6 +203,12 @@ class TypeAndShape {
   std::optional<Expr<SubscriptInteger>> MeasureSizeInBytes(
       FoldingContext &) const;
 
+  bool IsExplicitShape() const {
+    // If it's array and no special attributes are set, then must be
+    // explicit shape.
+    return Rank() > 0 && attrs_.none();
+  }
+
   // called by Fold() to rewrite in place
   TypeAndShape &Rewrite(FoldingContext &);
 

flang/include/flang/Evaluate/check-expression.h

@@ -125,6 +125,9 @@ std::optional<bool> IsContiguous(const A &, FoldingContext &,
 extern template std::optional<bool> IsContiguous(const Expr<SomeType> &,
     FoldingContext &, bool namedConstantSectionsAreContiguous,
     bool firstDimensionStride1);
+extern template std::optional<bool> IsContiguous(const ActualArgument &,
+    FoldingContext &, bool namedConstantSectionsAreContiguous,
+    bool firstDimensionStride1);
 extern template std::optional<bool> IsContiguous(const ArrayRef &,
     FoldingContext &, bool namedConstantSectionsAreContiguous,
     bool firstDimensionStride1);
@@ -160,5 +163,8 @@ extern template bool IsErrorExpr(const Expr<SomeType> &);
 std::optional<parser::Message> CheckStatementFunction(
     const Symbol &, const Expr<SomeType> &, FoldingContext &);
 
+bool MayNeedCopy(const ActualArgument *, const characteristics::DummyArgument *,
+    FoldingContext &, bool forCopyOut);
+
 } // namespace Fortran::evaluate
 #endif

flang/include/flang/Evaluate/tools.h

@@ -82,27 +82,6 @@ template <typename A> bool IsVariable(const A &x) {
   }
 }
 
-// Predicate: true when an expression is assumed-rank
-bool IsAssumedRank(const Symbol &);
-bool IsAssumedRank(const ActualArgument &);
-template <typename A> bool IsAssumedRank(const A &) { return false; }
-template <typename A> bool IsAssumedRank(const Designator<A> &designator) {
-  if (const auto *symbol{std::get_if<SymbolRef>(&designator.u)}) {
-    return IsAssumedRank(symbol->get());
-  } else {
-    return false;
-  }
-}
-template <typename T> bool IsAssumedRank(const Expr<T> &expr) {
-  return common::visit([](const auto &x) { return IsAssumedRank(x); }, expr.u);
-}
-template <typename A> bool IsAssumedRank(const std::optional<A> &x) {
-  return x && IsAssumedRank(*x);
-}
-template <typename A> bool IsAssumedRank(const A *x) {
-  return x && IsAssumedRank(*x);
-}
-
 // Finds the corank of an entity, possibly packaged in various ways.
 // Unlike rank, only data references have corank > 0.
 int GetCorank(const ActualArgument &);
@@ -1123,6 +1102,7 @@ extern template semantics::UnorderedSymbolSet CollectCudaSymbols(
 
 // Predicate: does a variable contain a vector-valued subscript (not a triplet)?
 bool HasVectorSubscript(const Expr<SomeType> &);
+bool HasVectorSubscript(const ActualArgument &);
 
 // Predicate: does an expression contain constant?
 bool HasConstant(const Expr<SomeType> &);
@@ -1555,7 +1535,19 @@ bool IsAllocatableOrObjectPointer(const Symbol *);
 bool IsAutomatic(const Symbol &);
 bool IsSaved(const Symbol &); // saved implicitly or explicitly
 bool IsDummy(const Symbol &);
+
+bool IsAssumedRank(const Symbol &);
+template <typename A> bool IsAssumedRank(const A &x) {
+  auto *symbol{UnwrapWholeSymbolDataRef(x)};
+  return symbol && IsAssumedRank(*symbol);
+}
+
 bool IsAssumedShape(const Symbol &);
+template <typename A> bool IsAssumedShape(const A &x) {
+  auto *symbol{UnwrapWholeSymbolDataRef(x)};
+  return symbol && IsAssumedShape(*symbol);
+}
+
 bool IsDeferredShape(const Symbol &);
 bool IsFunctionResult(const Symbol &);
 bool IsKindTypeParameter(const Symbol &);

flang/lib/Evaluate/check-expression.cpp

@@ -1001,8 +1001,8 @@ class IsContiguousHelper
       } else {
         return Base::operator()(ultimate); // use expr
       }
-    } else if (semantics::IsPointer(ultimate) ||
-        semantics::IsAssumedShape(ultimate) || IsAssumedRank(ultimate)) {
+    } else if (semantics::IsPointer(ultimate) || IsAssumedShape(ultimate) ||
+        IsAssumedRank(ultimate)) {
       return std::nullopt;
     } else if (ultimate.has<semantics::ObjectEntityDetails>()) {
       return true;
@@ -1282,9 +1282,21 @@ std::optional<bool> IsContiguous(const A &x, FoldingContext &context,
   }
 }
 
+std::optional<bool> IsContiguous(const ActualArgument &actual,
+    FoldingContext &fc, bool namedConstantSectionsAreContiguous,
+    bool firstDimensionStride1) {
+  auto *expr{actual.UnwrapExpr()};
+  return expr &&
+      IsContiguous(
+          *expr, fc, namedConstantSectionsAreContiguous, firstDimensionStride1);
+}
+
 template std::optional<bool> IsContiguous(const Expr<SomeType> &,
     FoldingContext &, bool namedConstantSectionsAreContiguous,
     bool firstDimensionStride1);
+template std::optional<bool> IsContiguous(const ActualArgument &,
+    FoldingContext &, bool namedConstantSectionsAreContiguous,
+    bool firstDimensionStride1);
 template std::optional<bool> IsContiguous(const ArrayRef &, FoldingContext &,
     bool namedConstantSectionsAreContiguous, bool firstDimensionStride1);
 template std::optional<bool> IsContiguous(const Substring &, FoldingContext &,
@@ -1434,4 +1446,177 @@ std::optional<parser::Message> CheckStatementFunction(
   return StmtFunctionChecker{sf, context}(expr);
 }
 
+// Helper class for checking differences between actual and dummy arguments
+class CopyInOutExplicitInterface {
+public:
+  explicit CopyInOutExplicitInterface(FoldingContext &fc,
+      const ActualArgument &actual,
+      const characteristics::DummyDataObject &dummyObj)
+      : fc_{fc}, actual_{actual}, dummyObj_{dummyObj} {}
+
+  // Returns true, if actual and dummy have different contiguity requirements
+  bool HaveContiguityDifferences() const {
+    // Check actual contiguity, unless dummy doesn't care
+    bool dummyTreatAsArray{dummyObj_.ignoreTKR.test(common::IgnoreTKR::Rank)};
+    bool actualTreatAsContiguous{
+        dummyObj_.ignoreTKR.test(common::IgnoreTKR::Contiguous) ||
+        IsSimplyContiguous(actual_, fc_)};
+    bool dummyIsExplicitShape{dummyObj_.type.IsExplicitShape()};
+    bool dummyIsAssumedSize{dummyObj_.type.attrs().test(
+        characteristics::TypeAndShape::Attr::AssumedSize)};
+    bool dummyIsPolymorphic{dummyObj_.type.type().IsPolymorphic()};
+    // type(*) with IGNORE_TKR(tkr) is often used to interface with C "void*".
+    // Since the other languages don't know about Fortran's discontiguity
+    // handling, such cases should require contiguity.
+    bool dummyIsVoidStar{dummyObj_.type.type().IsAssumedType() &&
+        dummyObj_.ignoreTKR.test(common::IgnoreTKR::Type) &&
+        dummyObj_.ignoreTKR.test(common::IgnoreTKR::Rank) &&
+        dummyObj_.ignoreTKR.test(common::IgnoreTKR::Kind)};
+    // Explicit shape and assumed size arrays must be contiguous
+    bool dummyNeedsContiguity{dummyIsExplicitShape || dummyIsAssumedSize ||
+        (dummyTreatAsArray && !dummyIsPolymorphic) || dummyIsVoidStar ||
+        dummyObj_.attrs.test(
+            characteristics::DummyDataObject::Attr::Contiguous)};
+    return !actualTreatAsContiguous && dummyNeedsContiguity;
+  }
+
+  // Returns true, if actual and dummy have polymorphic differences
+  bool HavePolymorphicDifferences() const {
+    bool dummyIsAssumedRank{dummyObj_.type.attrs().test(
+        characteristics::TypeAndShape::Attr::AssumedRank)};
+    bool actualIsAssumedRank{semantics::IsAssumedRank(actual_)};
+    bool dummyIsAssumedShape{dummyObj_.type.attrs().test(
+        characteristics::TypeAndShape::Attr::AssumedShape)};
+    bool actualIsAssumedShape{semantics::IsAssumedShape(actual_)};
+    if ((actualIsAssumedRank && dummyIsAssumedRank) ||
+        (actualIsAssumedShape && dummyIsAssumedShape)) {
+      // Assumed-rank and assumed-shape arrays are represented by descriptors,
+      // so don't need to do polymorphic check.
+    } else if (!dummyObj_.ignoreTKR.test(common::IgnoreTKR::Type)) {
+      // flang supports limited cases of passing polymorphic to non-polimorphic.
+      // These cases require temporary of non-polymorphic type. (For example,
+      // the actual argument could be polymorphic array of child type,
+      // while the dummy argument could be non-polymorphic array of parent
+      // type.)
+      bool dummyIsPolymorphic{dummyObj_.type.type().IsPolymorphic()};
+      auto actualType{
+          characteristics::TypeAndShape::Characterize(actual_, fc_)};
+      bool actualIsPolymorphic{
+          actualType && actualType->type().IsPolymorphic()};
+      if (actualIsPolymorphic && !dummyIsPolymorphic) {
+        return true;
+      }
+    }
+    return false;
+  }
+
+  bool HaveArrayOrAssumedRankArgs() const {
+    bool dummyTreatAsArray{dummyObj_.ignoreTKR.test(common::IgnoreTKR::Rank)};
+    return IsArrayOrAssumedRank(actual_) &&
+        (IsArrayOrAssumedRank(dummyObj_) || dummyTreatAsArray);
+  }
+
+  bool PassByValue() const {
+    return dummyObj_.attrs.test(characteristics::DummyDataObject::Attr::Value);
+  }
+
+  bool HaveCoarrayDifferences() const {
+    return ExtractCoarrayRef(actual_) && dummyObj_.type.corank() == 0;
+  }
+
+  bool HasIntentOut() const { return dummyObj_.intent == common::Intent::Out; }
+
+  bool HasIntentIn() const { return dummyObj_.intent == common::Intent::In; }
+
+  static bool IsArrayOrAssumedRank(const ActualArgument &actual) {
+    return semantics::IsAssumedRank(actual) || actual.Rank() > 0;
+  }
+
+  static bool IsArrayOrAssumedRank(
+      const characteristics::DummyDataObject &dummy) {
+    return dummy.type.attrs().test(
+               characteristics::TypeAndShape::Attr::AssumedRank) ||
+        dummy.type.Rank() > 0;
+  }
+
+private:
+  FoldingContext &fc_;
+  const ActualArgument &actual_;
+  const characteristics::DummyDataObject &dummyObj_;
+};
+
+// If forCopyOut is false, returns if a particular actual/dummy argument
+// combination may need a temporary creation with copy-in operation. If
+// forCopyOut is true, returns the same for copy-out operation. For
+// procedures with explicit interface, it's expected that "dummy" is not null.
+// For procedures with implicit interface dummy may be null.
+//
+// Note that these copy-in and copy-out checks are done from the caller's
+// perspective, meaning that for copy-in the caller need to do the copy
+// before calling the callee. Similarly, for copy-out the caller is expected
+// to do the copy after the callee returns.
+bool MayNeedCopy(const ActualArgument *actual,
+    const characteristics::DummyArgument *dummy, FoldingContext &fc,
+    bool forCopyOut) {
+  if (!actual) {
+    return false;
+  }
+  if (actual->isAlternateReturn()) {
+    return false;
+  }
+  const auto *dummyObj{dummy
+          ? std::get_if<characteristics::DummyDataObject>(&dummy->u)
+          : nullptr};
+  const bool forCopyIn = !forCopyOut;
+  if (!evaluate::IsVariable(*actual)) {
+    // Actual argument expressions that aren’t variables are copy-in, but
+    // not copy-out.
+    return forCopyIn;
+  }
+  if (dummyObj) { // Explict interface
+    CopyInOutExplicitInterface check{fc, *actual, *dummyObj};
+    if (forCopyOut && check.HasIntentIn()) {
+      // INTENT(IN) dummy args never need copy-out
+      return false;
+    }
+    if (forCopyIn && check.HasIntentOut()) {
+      // INTENT(OUT) dummy args never need copy-in
+      return false;
+    }
+    if (check.PassByValue()) {
+      // Pass by value, always copy-in, never copy-out
+      return forCopyIn;
+    }
+    if (check.HaveCoarrayDifferences()) {
+      return true;
+    }
+    // Note: contiguity and polymorphic checks deal with array or assumed rank
+    // arguments
+    if (!check.HaveArrayOrAssumedRankArgs()) {
+      return false;
+    }
+    if (check.HaveContiguityDifferences()) {
+      return true;
+    }
+    if (check.HavePolymorphicDifferences()) {
+      return true;
+    }
+  } else { // Implicit interface
+    if (ExtractCoarrayRef(*actual)) {
+      // Coindexed actual args may need copy-in and copy-out with implicit
+      // interface
+      return true;
+    }
+    if (!IsSimplyContiguous(*actual, fc)) {
+      // Copy-in:  actual arguments that are variables are copy-in when
+      //           non-contiguous.
+      // Copy-out: vector subscripts could refer to duplicate elements, can't
+      //           copy out.
+      return forCopyOut ? !HasVectorSubscript(*actual) : true;
+    }
+  }
+  // For everything else, no copy-in or copy-out
+  return false;
+}
+
 } // namespace Fortran::evaluate

flang/lib/Evaluate/fold-integer.cpp

@@ -38,13 +38,13 @@ static bool CheckDimArg(const std::optional<ActualArgument> &dimArg,
     const Expr<SomeType> &array, parser::ContextualMessages &messages,
     bool isLBound, std::optional<int> &dimVal) {
   dimVal.reset();
-  if (int rank{array.Rank()}; rank > 0 || IsAssumedRank(array)) {
+  if (int rank{array.Rank()}; rank > 0 || semantics::IsAssumedRank(array)) {
     auto named{ExtractNamedEntity(array)};
     if (auto dim64{ToInt64(dimArg)}) {
       if (*dim64 < 1) {
         messages.Say("DIM=%jd dimension must be positive"_err_en_US, *dim64);
         return false;
-      } else if (!IsAssumedRank(array) && *dim64 > rank) {
+      } else if (!semantics::IsAssumedRank(array) && *dim64 > rank) {
         messages.Say(
             "DIM=%jd dimension is out of range for rank-%d array"_err_en_US,
             *dim64, rank);
@@ -56,7 +56,7 @@ static bool CheckDimArg(const std::optional<ActualArgument> &dimArg,
             "DIM=%jd dimension is out of range for rank-%d assumed-size array"_err_en_US,
             *dim64, rank);
         return false;
-      } else if (IsAssumedRank(array)) {
+      } else if (semantics::IsAssumedRank(array)) {
         if (*dim64 > common::maxRank) {
           messages.Say(
               "DIM=%jd dimension is too large for any array (maximum rank %d)"_err_en_US,
@@ -189,7 +189,7 @@ Expr<Type<TypeCategory::Integer, KIND>> LBOUND(FoldingContext &context,
         return Expr<T>{std::move(funcRef)};
       }
     }
-    if (IsAssumedRank(*array)) {
+    if (semantics::IsAssumedRank(*array)) {
       // Would like to return 1 if DIM=.. is present, but that would be
       // hiding a runtime error if the DIM= were too large (including
       // the case of an assumed-rank argument that's scalar).
@@ -240,7 +240,7 @@ Expr<Type<TypeCategory::Integer, KIND>> UBOUND(FoldingContext &context,
         return Expr<T>{std::move(funcRef)};
       }
     }
-    if (IsAssumedRank(*array)) {
+    if (semantics::IsAssumedRank(*array)) {
     } else if (int rank{array->Rank()}; rank > 0) {
       bool takeBoundsFromShape{true};
       if (auto named{ExtractNamedEntity(*array)}) {

flang/lib/Evaluate/intrinsics.cpp

@@ -2256,7 +2256,7 @@ std::optional<SpecificCall> IntrinsicInterface::Match(
   for (std::size_t j{0}; j < dummies; ++j) {
     const IntrinsicDummyArgument &d{dummy[std::min(j, dummyArgPatterns - 1)]};
     if (const ActualArgument *arg{actualForDummy[j]}) {
-      bool isAssumedRank{IsAssumedRank(*arg)};
+      bool isAssumedRank{semantics::IsAssumedRank(*arg)};
       if (isAssumedRank && d.rank != Rank::anyOrAssumedRank &&
           d.rank != Rank::arrayOrAssumedRank) {
         messages.Say(arg->sourceLocation(),
@@ -3002,7 +3002,7 @@ SpecificCall IntrinsicProcTable::Implementation::HandleNull(
       mold = nullptr;
     }
     if (mold) {
-      if (IsAssumedRank(*arguments[0])) {
+      if (semantics::IsAssumedRank(*arguments[0])) {
         context.messages().Say(arguments[0]->sourceLocation(),
             "MOLD= argument to NULL() must not be assumed-rank"_err_en_US);
       }

flang/lib/Evaluate/shape.cpp

@@ -949,7 +949,7 @@ auto GetShapeHelper::operator()(const ProcedureRef &call) const -> Result {
         intrinsic->name == "ubound") {
       // For LBOUND/UBOUND, these are the array-valued cases (no DIM=)
       if (!call.arguments().empty() && call.arguments().front()) {
-        if (IsAssumedRank(*call.arguments().front())) {
+        if (semantics::IsAssumedRank(*call.arguments().front())) {
           return Shape{MaybeExtentExpr{}};
         } else {
           return Shape{