[flang] Fixed regression in copy-in/copy-out

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

@@ -163,8 +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);
+std::optional<bool> ActualArgNeedsCopy(const ActualArgument *,
+    const characteristics::DummyArgument *, FoldingContext &, bool forCopyOut);
 
 } // namespace Fortran::evaluate
 #endif

flang/lib/Evaluate/check-expression.cpp

@@ -1478,13 +1478,12 @@ class CopyInOutExplicitInterface {
       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
+  // Returns true if dummy arg needs to be contiguous
+  bool DummyNeedsContiguity() const {
+    if (dummyObj_.ignoreTKR.test(common::IgnoreTKR::Contiguous)) {
+      return false;
+    }
     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)};
@@ -1501,32 +1500,17 @@ class CopyInOutExplicitInterface {
         (dummyTreatAsArray && !dummyIsPolymorphic) || dummyIsVoidStar ||
         dummyObj_.attrs.test(
             characteristics::DummyDataObject::Attr::Contiguous)};
-    return !actualTreatAsContiguous && dummyNeedsContiguity;
+    return 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.)
+    if (dummyObj_.ignoreTKR.test(common::IgnoreTKR::Type)) {
+      return false;
+    }
+    if (auto actualType{
+            characteristics::TypeAndShape::Characterize(actual_, fc_)}) {
+      bool actualIsPolymorphic{actualType->type().IsPolymorphic()};
       bool dummyIsPolymorphic{dummyObj_.type.type().IsPolymorphic()};
-      auto actualType{
-          characteristics::TypeAndShape::Characterize(actual_, fc_)};
-      bool actualIsPolymorphic{
-          actualType && actualType->type().IsPolymorphic()};
       if (actualIsPolymorphic && !dummyIsPolymorphic) {
         return true;
       }
@@ -1575,28 +1559,32 @@ class CopyInOutExplicitInterface {
 // procedures with explicit interface, it's expected that "dummy" is not null.
 // For procedures with implicit interface dummy may be null.
 //
+// Returns std::optional<bool> indicating whether the copy is known to be
+// needed (true) or not needed (false); returns std::nullopt if the necessity
+// of the copy is undetermined.
+//
 // 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,
+std::optional<bool> ActualArgNeedsCopy(const ActualArgument *actual,
     const characteristics::DummyArgument *dummy, FoldingContext &fc,
     bool forCopyOut) {
   if (!actual) {
-    return false;
+    return std::nullopt;
   }
   if (actual->isAlternateReturn()) {
-    return false;
+    return std::nullopt;
   }
   const auto *dummyObj{dummy
           ? std::get_if<characteristics::DummyDataObject>(&dummy->u)
           : nullptr};
-  const bool forCopyIn = !forCopyOut;
+  const bool forCopyIn{!forCopyOut};
   if (!evaluate::IsVariable(*actual)) {
-    // Actual argument expressions that aren’t variables are copy-in, but
-    // not copy-out.
+    // Expressions are copy-in, but not copy-out.
     return forCopyIn;
   }
+  auto maybeContigActual{IsContiguous(*actual, fc)};
   if (dummyObj) { // Explict interface
     CopyInOutExplicitInterface check{fc, *actual, *dummyObj};
     if (forCopyOut && check.HasIntentIn()) {
@@ -1619,28 +1607,25 @@ bool MayNeedCopy(const ActualArgument *actual,
     if (!check.HaveArrayOrAssumedRankArgs()) {
       return false;
     }
-    if (check.HaveContiguityDifferences()) {
-      return true;
-    }
-    if (check.HavePolymorphicDifferences()) {
-      return true;
+    if (maybeContigActual.has_value()) {
+      // We know whether actual arg is contiguous or not
+      bool isContiguousActual{maybeContigActual.value()};
+      bool actualArgNeedsCopy{
+          (!isContiguousActual || check.HavePolymorphicDifferences()) &&
+          check.DummyNeedsContiguity()};
+      return actualArgNeedsCopy;
+    } else {
+      // We don't know whether actual arg is contiguous or not
+      return check.DummyNeedsContiguity();
     }
   } 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));
+    if (maybeContigActual.has_value()) {
+      // If known contiguous, don't copy in/out.
+      // If known non-contiguous, copy in/out.
+      return !*maybeContigActual;
     }
   }
-  // For everything else, no copy-in or copy-out
-  return false;
+  return std::nullopt;
 }
 
 } // namespace Fortran::evaluate

flang/lib/Lower/ConvertCall.cpp

@@ -1296,10 +1296,14 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
     Fortran::evaluate::FoldingContext &foldingContext{
         callContext.converter.getFoldingContext()};
 
-    bool suggestCopyIn = Fortran::evaluate::MayNeedCopy(
-        arg.entity, arg.characteristics, foldingContext, /*forCopyOut=*/false);
-    bool suggestCopyOut = Fortran::evaluate::MayNeedCopy(
-        arg.entity, arg.characteristics, foldingContext, /*forCopyOut=*/true);
+    bool suggestCopyIn = Fortran::evaluate::ActualArgNeedsCopy(
+                             arg.entity, arg.characteristics, foldingContext,
+                             /*forCopyOut=*/false)
+                             .value_or(true);
+    bool suggestCopyOut = Fortran::evaluate::ActualArgNeedsCopy(
+                              arg.entity, arg.characteristics, foldingContext,
+                              /*forCopyOut=*/true)
+                              .value_or(true);
     mustDoCopyIn = actual.isArray() && suggestCopyIn;
     mustDoCopyOut = actual.isArray() && suggestCopyOut;
   }

flang/lib/Semantics/check-call.cpp

@@ -795,7 +795,9 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
   bool dummyIsAssumedShape{dummy.type.attrs().test(
       characteristics::TypeAndShape::Attr::AssumedShape)};
   bool copyOutNeeded{
-      evaluate::MayNeedCopy(&arg, &dummyArg, foldingContext, true)};
+      evaluate::ActualArgNeedsCopy(&arg, &dummyArg, foldingContext,
+          /*forCopyOut=*/true)
+          .value_or(false)};
   if (copyOutNeeded && !dummyIsValue &&
       (dummyIsAsynchronous || dummyIsVolatile)) {
     if (actualIsAsynchronous || actualIsVolatile) {
@@ -832,8 +834,8 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
   // a unread value in the actual argument.
   // Occurences of `volatileOrAsyncNeedsTempDiagnosticIssued = true` indicate a
   // more specific error message has already been issued. We might be able to
-  // clean this up by switching the coding style of MayNeedCopy to be more like
-  // WhyNotDefinable.
+  // clean this up by switching the coding style of ActualArgNeedsCopy to be
+  // more like WhyNotDefinable.
   if (copyOutNeeded && !volatileOrAsyncNeedsTempDiagnosticIssued) {
     if ((actualIsVolatile || actualIsAsynchronous) &&
         (dummyIsVolatile || dummyIsAsynchronous)) {

flang/test/Lower/force-temp.f90

@@ -27,6 +27,14 @@ subroutine pass_intent_out(buf)
       integer, intent(out) :: buf(5)
     end subroutine
   end interface
+
+  ! Used by call_s6() and others below
+  type base
+    integer :: i = -1
+  end type
+  type, extends (base) :: child
+    real :: r = -2.0
+  end type
 contains
   subroutine s1(buf)
 !CHECK-LABEL: func.func @_QMtestPs1
@@ -79,4 +87,54 @@ subroutine s5()
     p => x(::2) ! pointer to non-contiguous array section
     call pass_intent_out(p)
   end subroutine
+  subroutine call_s6()
+    interface
+      subroutine s6(b)
+        import :: base
+        type(base), intent(inout) :: b(:)
+      end subroutine s6
+    end interface
+    class(base), pointer :: pb(:)
+    type(child), target :: c(2)
+!CHECK-LABEL: func.func @_QMtestPcall_s6
+!CHECK-NOT: hlfir.copy_in
+!CHECK: fir.call @_QPs6
+!CHECK-NOT: hlfir.copy_out
+    pb => c
+    call s6(pb)
+  end subroutine call_s6
+  subroutine call_s7()
+    interface
+      subroutine s7(b1, b2, n)
+        import :: base
+        integer :: n
+        type(base), intent(inout) :: b1(n)
+        type(base), intent(inout) :: b2(*)
+      end subroutine
+    end interface
+    integer, parameter :: n = 7
+    class(base), allocatable :: c1(:), c2(:)
+!CHECK-LABEL: func.func @_QMtestPcall_s7
+!CHECK: hlfir.copy_in
+!CHECK: hlfir.copy_in
+!CHECK: fir.call @_QPs7
+!CHECK: hlfir.copy_out
+!CHECK: hlfir.copy_out
+    call s7(c1, c2, n)
+  end subroutine call_s7
+  subroutine call_s8()
+    interface
+      subroutine s8(buf)
+        ! IGNORE_TKR(C) takes precendence over CONTIGUOUS
+        !DIR$ IGNORE_TKR(C) buf
+        real, contiguous :: buf(:)
+      end subroutine
+    end interface
+    real a(10)
+!CHECK-LABEL: func.func @_QMtestPcall_s8
+!CHECK-NOT: hlfir.copy_in
+!CHECK: fir.call @_QPs8
+!CHECK-NOT: hlfir.copy_out
+    call s8(a(1:5:2))
+  end subroutine call_s8
 end module