diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h index 18c244f6f450f..695223715869f 100644 --- a/flang/include/flang/Evaluate/tools.h +++ b/flang/include/flang/Evaluate/tools.h @@ -1123,6 +1123,9 @@ extern template semantics::UnorderedSymbolSet CollectCudaSymbols( // Predicate: does a variable contain a vector-valued subscript (not a triplet)? bool HasVectorSubscript(const Expr &); +// Predicate: does a variable contain a triplet? +bool HasTriplet(const Expr &); + // Predicate: does an expression contain constant? bool HasConstant(const Expr &); diff --git a/flang/include/flang/Lower/CallInterface.h b/flang/include/flang/Lower/CallInterface.h index 72bc9dd890a94..80003bfdfac8a 100644 --- a/flang/include/flang/Lower/CallInterface.h +++ b/flang/include/flang/Lower/CallInterface.h @@ -170,7 +170,7 @@ class CallInterface { /// Is the argument INTENT(OUT) bool isIntentOut() const; /// Does the argument have the CONTIGUOUS attribute or have explicit shape? - bool mustBeMadeContiguous() const; + bool mustBeMadeContiguous(bool argHasTriplet = false) const; /// Does the dummy argument have the VALUE attribute? bool hasValueAttribute() const; /// Does the dummy argument have the ALLOCATABLE attribute? diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp index 6a57d87a30e93..dbb8e84cac622 100644 --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -1173,6 +1173,22 @@ bool HasVectorSubscript(const Expr &expr) { return HasVectorSubscriptHelper{}(expr); } +// HasTriplet() +struct HasTripletHelper : public AnyTraverse { + using Base = AnyTraverse; + HasTripletHelper() : Base{*this} {} + using Base::operator(); + bool operator()(const Subscript &ss) const { + return std::holds_alternative(ss.u); + } + bool operator()(const ProcedureRef &) const { + return false; // don't descend into function call arguments + } +}; + +bool HasTriplet(const Expr &expr) { return HasTripletHelper{}(expr); } + // HasConstant() struct HasConstantHelper : public AnyTraverse { diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp index 72431a9cfacc4..80f8eb969797a 100644 --- a/flang/lib/Lower/CallInterface.cpp +++ b/flang/lib/Lower/CallInterface.cpp @@ -1416,9 +1416,12 @@ bool Fortran::lower::CallInterface::PassedEntity::isIntentOut() const { return true; return characteristics->GetIntent() == Fortran::common::Intent::Out; } + +/// Returning "true" from this function is a prerequisite for running +/// contiguity check on the actual argument. template -bool Fortran::lower::CallInterface::PassedEntity::mustBeMadeContiguous() - const { +bool Fortran::lower::CallInterface::PassedEntity::mustBeMadeContiguous( + const bool argHasTriplet) const { if (!characteristics) return true; const auto *dummy = @@ -1426,6 +1429,13 @@ bool Fortran::lower::CallInterface::PassedEntity::mustBeMadeContiguous() &characteristics->u); if (!dummy) return false; + if (dummy->ignoreTKR.test(common::IgnoreTKR::Contiguous)) + return false; + + // TODO: should this check ignore "device" or "managed"? + if (dummy->ignoreTKR.any() && argHasTriplet) + return true; + const auto &shapeAttrs = dummy->type.attrs(); using ShapeAttrs = Fortran::evaluate::characteristics::TypeAndShape::Attr; if (shapeAttrs.test(ShapeAttrs::AssumedRank) || diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp index 6ed15df0de754..4d7d142c6b49d 100644 --- a/flang/lib/Lower/ConvertCall.cpp +++ b/flang/lib/Lower/ConvertCall.cpp @@ -1255,11 +1255,21 @@ static PreparedDummyArgument preparePresentUserCallActualArgument( passingPolymorphicToNonPolymorphic && (actual.isArray() || mlir::isa(dummyType)); + // Helper function to make it easier to unwrap and use expression + auto argHasTriplet = + [](const Fortran::evaluate::ActualArgument &arg) -> bool { + if (const auto *expr = arg.UnwrapExpr()) + return HasTriplet(*expr); + return false; + }; + + const bool actualHasTriplet = argHasTriplet(*arg.entity); + // The simple contiguity of the actual is "lost" when passing a polymorphic // to a non polymorphic entity because the dummy dynamic type matters for // the contiguity. const bool mustDoCopyInOut = - actual.isArray() && arg.mustBeMadeContiguous() && + actual.isArray() && arg.mustBeMadeContiguous(actualHasTriplet) && (passingPolymorphicToNonPolymorphic || !isSimplyContiguous(*arg.entity, foldingContext)); diff --git a/flang/test/Lower/force-temp.f90 b/flang/test/Lower/force-temp.f90 new file mode 100644 index 0000000000000..816feb2366421 --- /dev/null +++ b/flang/test/Lower/force-temp.f90 @@ -0,0 +1,58 @@ +! RUN: bbc -emit-hlfir -o - %s | FileCheck %s +! Ensure that we still create copy_in/copy_out for non-contiguous input, +! despite having IGNORE_TKR. +! +module test + implicit none(type, external) +contains + subroutine pass_ignore_tkr(buf, n) + implicit none + !DIR$ IGNORE_TKR buf + real, intent(inout) :: buf(n) + integer, intent(in) :: n + end subroutine + + subroutine pass_ignore_tkr_c(buf, n) + implicit none + !DIR$ IGNORE_TKR (tkrc) buf + real, intent(inout) :: buf(n) + integer, intent(in) :: n + end subroutine + + subroutine s1() +!CHECK-LABEL: func.func @_QMtestPs1() +!CHECK: hlfir.copy_in +!CHECK: fir.call @_QMtestPpass_ignore_tkr +!CHECK: hlfir.copy_out + + integer :: x(5) + x = [1,2,3,4,5] + ! Non-contiguous input + call pass_ignore_tkr(x(1::2), size(x(1::2))) + end subroutine s1 + + subroutine s2() +!CHECK-LABEL: func.func @_QMtestPs2() +!CHECK-NOT: hlfir.copy_in +!CHECK: fir.call @_QMtestPpass_ignore_tkr +!CHECK-NOT: hlfir.copy_out + + integer :: x(5) + x = [1,2,3,4,5] + ! Contiguous input + call pass_ignore_tkr(x(1:3), size(x(1:3))) + end subroutine s2 + + subroutine s3() +!CHECK-LABEL: func.func @_QMtestPs3() +!CHECK-NOT: hlfir.copy_in +!CHECK: fir.call @_QMtestPpass_ignore_tkr_c +!CHECK-NOT: hlfir.copy_out + + integer :: x(5) + x = [1,2,3,4,5] + ! Non-contiguous input, but the dummy arg declaration ignores + ! the contiguity check + call pass_ignore_tkr_c(x(1::2), size(x(1::2))) + end subroutine s3 +end module test