[llvm-branch-commits] [flang] [flang] Consolidate copy-in/copy-out determination in evaluate framework (PR #155810)
Tom Eccles via llvm-branch-commits
llvm-branch-commits at lists.llvm.org
Thu Aug 28 03:16:11 PDT 2025
https://github.com/tblah created https://github.com/llvm/llvm-project/pull/155810
Backport of #151408
New implementation of `MayNeedCopy()` is used to consolidate copy-in/copy-out checks.
`IsAssumedShape()` and `IsAssumedRank()` were simplified and are both now in `Fortran::semantics` workspace.
`preparePresentUserCallActualArgument()` in lowering was modified to use `MayNeedCopyInOut()`
Fixes https://github.com/llvm/llvm-project/issues/138471
Conflicts in backport were trivial. Remove modifications of new code not present in 21.x branch:
flang/lib/Semantics/check-omp-structure.cpp
flang/lib/Semantics/resolve-directives.cpp
>From 3f280e53ac9d613c777ad59876c2da562f2b870c Mon Sep 17 00:00:00 2001
From: Eugene Epshteyn <eepshteyn at nvidia.com>
Date: Tue, 26 Aug 2025 18:40:13 -0400
Subject: [PATCH] [flang] Consolidate copy-in/copy-out determination in
evaluate framework
Backport of #151408
New implementation of `MayNeedCopy()` is used to consolidate
copy-in/copy-out checks.
`IsAssumedShape()` and `IsAssumedRank()` were simplified and are both
now in `Fortran::semantics` workspace.
`preparePresentUserCallActualArgument()` in lowering was modified to use
`MayNeedCopyInOut()`
Fixes https://github.com/llvm/llvm-project/issues/138471
Conflicts in backport were trivial. Remove modifications of new code
not present in 21.x branch:
flang/lib/Semantics/check-omp-structure.cpp
flang/lib/Semantics/resolve-directives.cpp
---
.../include/flang/Evaluate/characteristics.h | 6 +
.../include/flang/Evaluate/check-expression.h | 6 +
flang/include/flang/Evaluate/tools.h | 34 ++--
flang/lib/Evaluate/check-expression.cpp | 189 +++++++++++++++++-
flang/lib/Evaluate/fold-integer.cpp | 10 +-
flang/lib/Evaluate/intrinsics.cpp | 4 +-
flang/lib/Evaluate/shape.cpp | 2 +-
flang/lib/Evaluate/tools.cpp | 43 ++--
flang/lib/Lower/ConvertCall.cpp | 61 +++---
flang/lib/Lower/ConvertExpr.cpp | 2 +-
flang/lib/Lower/ConvertVariable.cpp | 4 +-
flang/lib/Lower/HostAssociations.cpp | 4 +-
flang/lib/Semantics/check-allocate.cpp | 2 +-
flang/lib/Semantics/check-call.cpp | 9 +-
flang/lib/Semantics/check-declarations.cpp | 12 +-
flang/lib/Semantics/check-select-rank.cpp | 2 +-
flang/lib/Semantics/check-select-type.cpp | 2 +-
flang/lib/Semantics/expression.cpp | 2 +-
flang/lib/Semantics/pointer-assignment.cpp | 2 +-
flang/lib/Semantics/resolve-names.cpp | 2 +-
flang/lib/Semantics/tools.cpp | 6 +-
flang/test/Lower/force-temp.f90 | 82 ++++++++
22 files changed, 379 insertions(+), 107 deletions(-)
create mode 100644 flang/test/Lower/force-temp.f90
diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index d566c34ff71e8..b6a9ebefec9df 100644
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/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 &);
diff --git a/flang/include/flang/Evaluate/check-expression.h b/flang/include/flang/Evaluate/check-expression.h
index 0cf12f340ec5c..9a0885f4d0996 100644
--- a/flang/include/flang/Evaluate/check-expression.h
+++ b/flang/include/flang/Evaluate/check-expression.h
@@ -118,6 +118,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);
@@ -153,5 +156,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
diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h
index 96ed86f468350..55f23fbdcbb70 100644
--- a/flang/include/flang/Evaluate/tools.h
+++ b/flang/include/flang/Evaluate/tools.h
@@ -81,27 +81,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 &);
@@ -1122,6 +1101,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> &);
@@ -1548,7 +1528,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 &);
diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp
index 3d7f01d56c465..aae92933e42d8 100644
--- a/flang/lib/Evaluate/check-expression.cpp
+++ b/flang/lib/Evaluate/check-expression.cpp
@@ -917,8 +917,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;
@@ -1198,9 +1198,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 &,
@@ -1350,4 +1362,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));
+ }
+ }
+ // For everything else, no copy-in or copy-out
+ return false;
+}
+
} // namespace Fortran::evaluate
diff --git a/flang/lib/Evaluate/fold-integer.cpp b/flang/lib/Evaluate/fold-integer.cpp
index 352dec4bb5ee2..ac50e77eae578 100644
--- a/flang/lib/Evaluate/fold-integer.cpp
+++ b/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)}) {
diff --git a/flang/lib/Evaluate/intrinsics.cpp b/flang/lib/Evaluate/intrinsics.cpp
index 4773e136c41cb..72513fff9f618 100644
--- a/flang/lib/Evaluate/intrinsics.cpp
+++ b/flang/lib/Evaluate/intrinsics.cpp
@@ -2251,7 +2251,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(),
@@ -2997,7 +2997,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);
}
diff --git a/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp
index 776866d1416d2..bca95cbbba970 100644
--- a/flang/lib/Evaluate/shape.cpp
+++ b/flang/lib/Evaluate/shape.cpp
@@ -947,7 +947,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{
diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp
index 21e6b3c3dd50d..9273fcfa6a747 100644
--- a/flang/lib/Evaluate/tools.cpp
+++ b/flang/lib/Evaluate/tools.cpp
@@ -890,29 +890,6 @@ std::optional<Expr<SomeType>> ConvertToType(
}
}
-bool IsAssumedRank(const Symbol &original) {
- if (const auto *assoc{original.detailsIf<semantics::AssocEntityDetails>()}) {
- if (assoc->rank()) {
- return false; // in RANK(n) or RANK(*)
- } else if (assoc->IsAssumedRank()) {
- return true; // RANK DEFAULT
- }
- }
- const Symbol &symbol{semantics::ResolveAssociations(original)};
- const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()};
- return object && object->IsAssumedRank();
-}
-
-bool IsAssumedRank(const ActualArgument &arg) {
- if (const auto *expr{arg.UnwrapExpr()}) {
- return IsAssumedRank(*expr);
- } else {
- const Symbol *assumedTypeDummy{arg.GetAssumedTypeDummy()};
- CHECK(assumedTypeDummy);
- return IsAssumedRank(*assumedTypeDummy);
- }
-}
-
int GetCorank(const ActualArgument &arg) {
const auto *expr{arg.UnwrapExpr()};
return GetCorank(*expr);
@@ -1203,6 +1180,11 @@ bool HasVectorSubscript(const Expr<SomeType> &expr) {
return HasVectorSubscriptHelper{}(expr);
}
+bool HasVectorSubscript(const ActualArgument &actual) {
+ auto expr{actual.UnwrapExpr()};
+ return expr && HasVectorSubscript(*expr);
+}
+
// HasConstant()
struct HasConstantHelper : public AnyTraverse<HasConstantHelper, bool,
/*TraverseAssocEntityDetails=*/false> {
@@ -2276,9 +2258,22 @@ bool IsDummy(const Symbol &symbol) {
ResolveAssociations(symbol).details());
}
+bool IsAssumedRank(const Symbol &original) {
+ if (const auto *assoc{original.detailsIf<semantics::AssocEntityDetails>()}) {
+ if (assoc->rank()) {
+ return false; // in RANK(n) or RANK(*)
+ } else if (assoc->IsAssumedRank()) {
+ return true; // RANK DEFAULT
+ }
+ }
+ const Symbol &symbol{semantics::ResolveAssociations(original)};
+ const auto *object{symbol.detailsIf<semantics::ObjectEntityDetails>()};
+ return object && object->IsAssumedRank();
+}
+
bool IsAssumedShape(const Symbol &symbol) {
const Symbol &ultimate{ResolveAssociations(symbol)};
- const auto *object{ultimate.detailsIf<ObjectEntityDetails>()};
+ const auto *object{ultimate.detailsIf<semantics::ObjectEntityDetails>()};
return object && object->IsAssumedShape() &&
!semantics::IsAllocatableOrObjectPointer(&ultimate);
}
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index 6ed15df0de754..1c63a07f08f94 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -881,9 +881,10 @@ struct CallContext {
std::optional<mlir::Type> resultType, mlir::Location loc,
Fortran::lower::AbstractConverter &converter,
Fortran::lower::SymMap &symMap,
- Fortran::lower::StatementContext &stmtCtx)
+ Fortran::lower::StatementContext &stmtCtx, bool doCopyIn = true)
: procRef{procRef}, converter{converter}, symMap{symMap},
- stmtCtx{stmtCtx}, resultType{resultType}, loc{loc} {}
+ stmtCtx{stmtCtx}, resultType{resultType}, loc{loc}, doCopyIn{doCopyIn} {
+ }
fir::FirOpBuilder &getBuilder() { return converter.getFirOpBuilder(); }
@@ -925,6 +926,7 @@ struct CallContext {
Fortran::lower::StatementContext &stmtCtx;
std::optional<mlir::Type> resultType;
mlir::Location loc;
+ bool doCopyIn;
};
using ExvAndCleanup =
@@ -1162,18 +1164,6 @@ mlir::Value static getZeroLowerBounds(mlir::Location loc,
return builder.genShift(loc, lowerBounds);
}
-static bool
-isSimplyContiguous(const Fortran::evaluate::ActualArgument &arg,
- Fortran::evaluate::FoldingContext &foldingContext) {
- if (const auto *expr = arg.UnwrapExpr())
- return Fortran::evaluate::IsSimplyContiguous(*expr, foldingContext);
- const Fortran::semantics::Symbol *sym = arg.GetAssumedTypeDummy();
- assert(sym &&
- "expect ActualArguments to be expression or assumed-type symbols");
- return sym->Rank() == 0 ||
- Fortran::evaluate::IsSimplyContiguous(*sym, foldingContext);
-}
-
static bool isParameterObjectOrSubObject(hlfir::Entity entity) {
mlir::Value base = entity;
bool foundParameter = false;
@@ -1205,6 +1195,10 @@ static bool isParameterObjectOrSubObject(hlfir::Entity entity) {
/// fir.box_char...).
/// This function should only be called with an actual that is present.
/// The optional aspects must be handled by this function user.
+///
+/// Note: while Fortran::lower::CallerInterface::PassedEntity (the type of arg)
+/// is technically a template type, in the prepare*ActualArgument() calls
+/// it resolves to Fortran::evaluate::ActualArgument *
static PreparedDummyArgument preparePresentUserCallActualArgument(
mlir::Location loc, fir::FirOpBuilder &builder,
const Fortran::lower::PreparedActualArgument &preparedActual,
@@ -1212,9 +1206,6 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
const Fortran::lower::CallerInterface::PassedEntity &arg,
CallContext &callContext) {
- Fortran::evaluate::FoldingContext &foldingContext =
- callContext.converter.getFoldingContext();
-
// Step 1: get the actual argument, which includes addressing the
// element if this is an array in an elemental call.
hlfir::Entity actual = preparedActual.getActual(loc, builder);
@@ -1255,13 +1246,20 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
passingPolymorphicToNonPolymorphic &&
(actual.isArray() || mlir::isa<fir::BaseBoxType>(dummyType));
- // 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() &&
- (passingPolymorphicToNonPolymorphic ||
- !isSimplyContiguous(*arg.entity, foldingContext));
+ bool mustDoCopyIn{false};
+ bool mustDoCopyOut{false};
+
+ if (callContext.doCopyIn) {
+ 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);
+ mustDoCopyIn = actual.isArray() && suggestCopyIn;
+ mustDoCopyOut = actual.isArray() && suggestCopyOut;
+ }
const bool actualIsAssumedRank = actual.isAssumedRank();
// Create dummy type with actual argument rank when the dummy is an assumed
@@ -1370,8 +1368,14 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
entity = hlfir::Entity{associate.getBase()};
// Register the temporary destruction after the call.
preparedDummy.pushExprAssociateCleanUp(associate);
- } else if (mustDoCopyInOut) {
+ } else if (mustDoCopyIn || mustDoCopyOut) {
// Copy-in non contiguous variables.
+ //
+ // TODO: copy-in and copy-out are now determined separately, in order
+ // to allow more fine grained copying. While currently both copy-in
+ // and copy-out are must be done together, these copy operations could
+ // be separated in the future. (This is related to TODO comment below.)
+ //
// TODO: for non-finalizable monomorphic derived type actual
// arguments associated with INTENT(OUT) dummy arguments
// we may avoid doing the copy and only allocate the temporary.
@@ -1379,7 +1383,7 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
// allocation for the temp in this case. We can communicate
// this to the codegen via some CopyInOp flag.
// This is a performance concern.
- entity = genCopyIn(entity, arg.mayBeModifiedByCall());
+ entity = genCopyIn(entity, mustDoCopyOut);
}
} else {
const Fortran::lower::SomeExpr *expr = arg.entity->UnwrapExpr();
@@ -2964,8 +2968,11 @@ void Fortran::lower::convertUserDefinedAssignmentToHLFIR(
const evaluate::ProcedureRef &procRef, hlfir::Entity lhs, hlfir::Entity rhs,
Fortran::lower::SymMap &symMap) {
Fortran::lower::StatementContext definedAssignmentContext;
+ // For defined assignment, don't use regular copy-in/copy-out mechanism:
+ // defined assignment generates hlfir.region_assign construct, and this
+ // construct automatically handles any copy-in.
CallContext callContext(procRef, /*resultType=*/std::nullopt, loc, converter,
- symMap, definedAssignmentContext);
+ symMap, definedAssignmentContext, /*doCopyIn=*/false);
Fortran::lower::CallerInterface caller(procRef, converter);
mlir::FunctionType callSiteType = caller.genFunctionType();
PreparedActualArgument preparedLhs{lhs, /*isPresent=*/std::nullopt};
diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp
index f3430bfa3021e..b932bfd565a66 100644
--- a/flang/lib/Lower/ConvertExpr.cpp
+++ b/flang/lib/Lower/ConvertExpr.cpp
@@ -2748,7 +2748,7 @@ class ScalarExprLowering {
fir::unwrapSequenceType(fir::unwrapPassByRefType(argTy))))
TODO(loc, "passing to an OPTIONAL CONTIGUOUS derived type argument "
"with length parameters");
- if (Fortran::evaluate::IsAssumedRank(*expr))
+ if (Fortran::semantics::IsAssumedRank(*expr))
TODO(loc, "passing an assumed rank entity to an OPTIONAL "
"CONTIGUOUS argument");
// Assumed shape VALUE are currently TODO in the call interface
diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp
index ffe456de56630..dabbdd1e8829f 100644
--- a/flang/lib/Lower/ConvertVariable.cpp
+++ b/flang/lib/Lower/ConvertVariable.cpp
@@ -1729,7 +1729,7 @@ static bool lowerToBoxValue(const Fortran::semantics::Symbol &sym,
return true;
// Assumed rank and optional fir.box cannot yet be read while lowering the
// specifications.
- if (Fortran::evaluate::IsAssumedRank(sym) ||
+ if (Fortran::semantics::IsAssumedRank(sym) ||
Fortran::semantics::IsOptional(sym))
return true;
// Polymorphic entity should be tracked through a fir.box that has the
@@ -2188,7 +2188,7 @@ void Fortran::lower::mapSymbolAttributes(
return;
}
- const bool isAssumedRank = Fortran::evaluate::IsAssumedRank(sym);
+ const bool isAssumedRank = Fortran::semantics::IsAssumedRank(sym);
if (isAssumedRank && !allowAssumedRank)
TODO(loc, "assumed-rank variable in procedure implemented in Fortran");
diff --git a/flang/lib/Lower/HostAssociations.cpp b/flang/lib/Lower/HostAssociations.cpp
index 6a44be65a6cde..ee6a96abee51a 100644
--- a/flang/lib/Lower/HostAssociations.cpp
+++ b/flang/lib/Lower/HostAssociations.cpp
@@ -431,7 +431,7 @@ class CapturedArrays : public CapturedSymbols<CapturedArrays> {
mlir::Value box = args.valueInTuple;
mlir::IndexType idxTy = builder.getIndexType();
llvm::SmallVector<mlir::Value> lbounds;
- if (!ba.lboundIsAllOnes() && !Fortran::evaluate::IsAssumedRank(sym)) {
+ if (!ba.lboundIsAllOnes() && !Fortran::semantics::IsAssumedRank(sym)) {
if (ba.isStaticArray()) {
for (std::int64_t lb : ba.staticLBound())
lbounds.emplace_back(builder.createIntegerConstant(loc, idxTy, lb));
@@ -490,7 +490,7 @@ class CapturedArrays : public CapturedSymbols<CapturedArrays> {
bool isPolymorphic = type && type->IsPolymorphic();
return isScalarOrContiguous && !isPolymorphic &&
!isDerivedWithLenParameters(sym) &&
- !Fortran::evaluate::IsAssumedRank(sym);
+ !Fortran::semantics::IsAssumedRank(sym);
}
};
} // namespace
diff --git a/flang/lib/Semantics/check-allocate.cpp b/flang/lib/Semantics/check-allocate.cpp
index 08053594c12e4..823aa4e795e35 100644
--- a/flang/lib/Semantics/check-allocate.cpp
+++ b/flang/lib/Semantics/check-allocate.cpp
@@ -548,7 +548,7 @@ bool AllocationCheckerHelper::RunChecks(SemanticsContext &context) {
}
}
// Shape related checks
- if (ultimate_ && evaluate::IsAssumedRank(*ultimate_)) {
+ if (ultimate_ && IsAssumedRank(*ultimate_)) {
context.Say(name_.source,
"An assumed-rank dummy argument may not appear in an ALLOCATE statement"_err_en_US);
return false;
diff --git a/flang/lib/Semantics/check-call.cpp b/flang/lib/Semantics/check-call.cpp
index 6f2503285013d..067439fccb617 100644
--- a/flang/lib/Semantics/check-call.cpp
+++ b/flang/lib/Semantics/check-call.cpp
@@ -67,7 +67,7 @@ static void CheckImplicitInterfaceArg(evaluate::ActualArgument &arg,
"Null pointer argument requires an explicit interface"_err_en_US);
} else if (auto named{evaluate::ExtractNamedEntity(*expr)}) {
const Symbol &symbol{named->GetLastSymbol()};
- if (evaluate::IsAssumedRank(symbol)) {
+ if (IsAssumedRank(symbol)) {
messages.Say(
"Assumed rank argument requires an explicit interface"_err_en_US);
}
@@ -131,7 +131,7 @@ static void CheckCharacterActual(evaluate::Expr<evaluate::SomeType> &actual,
dummy.type.type().kind() == actualType.type().kind() &&
!dummy.attrs.test(
characteristics::DummyDataObject::Attr::DeducedFromActual)) {
- bool actualIsAssumedRank{evaluate::IsAssumedRank(actual)};
+ bool actualIsAssumedRank{IsAssumedRank(actual)};
if (actualIsAssumedRank &&
!dummy.type.attrs().test(
characteristics::TypeAndShape::Attr::AssumedRank)) {
@@ -387,7 +387,7 @@ static void CheckExplicitDataArg(const characteristics::DummyDataObject &dummy,
characteristics::TypeAndShape::Attr::AssumedRank)};
bool actualIsAssumedSize{actualType.attrs().test(
characteristics::TypeAndShape::Attr::AssumedSize)};
- bool actualIsAssumedRank{evaluate::IsAssumedRank(actual)};
+ bool actualIsAssumedRank{IsAssumedRank(actual)};
bool actualIsPointer{evaluate::IsObjectPointer(actual)};
bool actualIsAllocatable{evaluate::IsAllocatableDesignator(actual)};
bool actualMayBeAssumedSize{actualIsAssumedSize ||
@@ -1395,8 +1395,7 @@ static void CheckExplicitInterfaceArg(evaluate::ActualArgument &arg,
assumed.name(), dummyName);
} else if (object.type.attrs().test(characteristics::
TypeAndShape::Attr::AssumedRank) &&
- !IsAssumedShape(assumed) &&
- !evaluate::IsAssumedRank(assumed)) {
+ !IsAssumedShape(assumed) && !IsAssumedRank(assumed)) {
messages.Say( // C711
"Assumed-type '%s' must be either assumed shape or assumed rank to be associated with assumed rank %s"_err_en_US,
assumed.name(), dummyName);
diff --git a/flang/lib/Semantics/check-declarations.cpp b/flang/lib/Semantics/check-declarations.cpp
index f9d64485f1407..950fd6b51a843 100644
--- a/flang/lib/Semantics/check-declarations.cpp
+++ b/flang/lib/Semantics/check-declarations.cpp
@@ -609,7 +609,7 @@ void CheckHelper::CheckValue(
"VALUE attribute may not apply to a type with a coarray ultimate component"_err_en_US);
}
}
- if (evaluate::IsAssumedRank(symbol)) {
+ if (IsAssumedRank(symbol)) {
messages_.Say(
"VALUE attribute may not apply to an assumed-rank array"_err_en_US);
}
@@ -719,7 +719,7 @@ void CheckHelper::CheckObjectEntity(
"Coarray '%s' may not have type TEAM_TYPE, C_PTR, or C_FUNPTR"_err_en_US,
symbol.name());
}
- if (evaluate::IsAssumedRank(symbol)) {
+ if (IsAssumedRank(symbol)) {
messages_.Say("Coarray '%s' may not be an assumed-rank array"_err_en_US,
symbol.name());
}
@@ -865,7 +865,7 @@ void CheckHelper::CheckObjectEntity(
"!DIR$ IGNORE_TKR may not apply to an allocatable or pointer"_err_en_US);
}
} else if (ignoreTKR.test(common::IgnoreTKR::Rank)) {
- if (ignoreTKR.count() == 1 && evaluate::IsAssumedRank(symbol)) {
+ if (ignoreTKR.count() == 1 && IsAssumedRank(symbol)) {
Warn(common::UsageWarning::IgnoreTKRUsage,
"!DIR$ IGNORE_TKR(R) is not meaningful for an assumed-rank array"_warn_en_US);
} else if (inExplicitExternalInterface) {
@@ -1190,7 +1190,7 @@ void CheckHelper::CheckObjectEntity(
SayWithDeclaration(symbol,
"Deferred-shape entity of %s type is not supported"_err_en_US,
typeName);
- } else if (evaluate::IsAssumedRank(symbol)) {
+ } else if (IsAssumedRank(symbol)) {
SayWithDeclaration(symbol,
"Assumed rank entity of %s type is not supported"_err_en_US,
typeName);
@@ -2404,7 +2404,7 @@ void CheckHelper::CheckVolatile(const Symbol &symbol,
void CheckHelper::CheckContiguous(const Symbol &symbol) {
if (evaluate::IsVariable(symbol) &&
((IsPointer(symbol) && symbol.Rank() > 0) || IsAssumedShape(symbol) ||
- evaluate::IsAssumedRank(symbol))) {
+ IsAssumedRank(symbol))) {
} else {
parser::MessageFixedText msg{symbol.owner().IsDerivedType()
? "CONTIGUOUS component '%s' should be an array with the POINTER attribute"_port_en_US
@@ -3433,7 +3433,7 @@ void CheckHelper::CheckBindC(const Symbol &symbol) {
bool CheckHelper::CheckDioDummyIsData(
const Symbol &subp, const Symbol *arg, std::size_t position) {
if (arg && arg->detailsIf<ObjectEntityDetails>()) {
- if (evaluate::IsAssumedRank(*arg)) {
+ if (IsAssumedRank(*arg)) {
messages_.Say(arg->name(),
"Dummy argument '%s' may not be assumed-rank"_err_en_US, arg->name());
return false;
diff --git a/flang/lib/Semantics/check-select-rank.cpp b/flang/lib/Semantics/check-select-rank.cpp
index b227bbaaef4ba..5dade2ca696c1 100644
--- a/flang/lib/Semantics/check-select-rank.cpp
+++ b/flang/lib/Semantics/check-select-rank.cpp
@@ -32,7 +32,7 @@ void SelectRankConstructChecker::Leave(
const Symbol *saveSelSymbol{nullptr};
if (const auto selExpr{GetExprFromSelector(selectRankStmtSel)}) {
if (const Symbol * sel{evaluate::UnwrapWholeSymbolDataRef(*selExpr)}) {
- if (!evaluate::IsAssumedRank(*sel)) { // C1150
+ if (!semantics::IsAssumedRank(*sel)) { // C1150
context_.Say(parser::FindSourceLocation(selectRankStmtSel),
"Selector '%s' is not an assumed-rank array variable"_err_en_US,
sel->name().ToString());
diff --git a/flang/lib/Semantics/check-select-type.cpp b/flang/lib/Semantics/check-select-type.cpp
index 94d16a719277a..b1b22c3e7c4a2 100644
--- a/flang/lib/Semantics/check-select-type.cpp
+++ b/flang/lib/Semantics/check-select-type.cpp
@@ -252,7 +252,7 @@ void SelectTypeChecker::Enter(const parser::SelectTypeConstruct &construct) {
if (IsProcedure(*selector)) {
context_.Say(
selectTypeStmt.source, "Selector may not be a procedure"_err_en_US);
- } else if (evaluate::IsAssumedRank(*selector)) {
+ } else if (IsAssumedRank(*selector)) {
context_.Say(selectTypeStmt.source,
"Assumed-rank variable may only be used as actual argument"_err_en_US);
} else if (auto exprType{selector->GetType()}) {
diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp
index 53ec3827893d0..795e2ddf51c4c 100644
--- a/flang/lib/Semantics/expression.cpp
+++ b/flang/lib/Semantics/expression.cpp
@@ -4606,7 +4606,7 @@ bool ArgumentAnalyzer::CheckForNullPointer(const char *where) {
bool ArgumentAnalyzer::CheckForAssumedRank(const char *where) {
for (const std::optional<ActualArgument> &arg : actuals_) {
- if (arg && IsAssumedRank(arg->UnwrapExpr())) {
+ if (arg && semantics::IsAssumedRank(arg->UnwrapExpr())) {
context_.Say(source_,
"An assumed-rank dummy argument is not allowed %s"_err_en_US, where);
fatalErrors_ = true;
diff --git a/flang/lib/Semantics/pointer-assignment.cpp b/flang/lib/Semantics/pointer-assignment.cpp
index 090876912138a..deb9c0470ed14 100644
--- a/flang/lib/Semantics/pointer-assignment.cpp
+++ b/flang/lib/Semantics/pointer-assignment.cpp
@@ -159,7 +159,7 @@ bool PointerAssignmentChecker::CheckLeftHandSide(const SomeExpr &lhs) {
msg->Attach(std::move(whyNot->set_severity(parser::Severity::Because)));
}
return false;
- } else if (evaluate::IsAssumedRank(lhs)) {
+ } else if (IsAssumedRank(lhs)) {
Say("The left-hand side of a pointer assignment must not be an assumed-rank dummy argument"_err_en_US);
return false;
} else if (evaluate::ExtractCoarrayRef(lhs)) { // F'2023 C1027
diff --git a/flang/lib/Semantics/resolve-names.cpp b/flang/lib/Semantics/resolve-names.cpp
index 96faa5fd954cd..11f096ee64668 100644
--- a/flang/lib/Semantics/resolve-names.cpp
+++ b/flang/lib/Semantics/resolve-names.cpp
@@ -7880,7 +7880,7 @@ void ConstructVisitor::Post(const parser::AssociateStmt &x) {
if (ExtractCoarrayRef(expr)) { // C1103
Say("Selector must not be a coindexed object"_err_en_US);
}
- if (evaluate::IsAssumedRank(expr)) {
+ if (IsAssumedRank(expr)) {
Say("Selector must not be assumed-rank"_err_en_US);
}
SetTypeFromAssociation(*symbol);
diff --git a/flang/lib/Semantics/tools.cpp b/flang/lib/Semantics/tools.cpp
index 5e5b43f26c791..98474f90dbdc5 100644
--- a/flang/lib/Semantics/tools.cpp
+++ b/flang/lib/Semantics/tools.cpp
@@ -705,7 +705,7 @@ SymbolVector FinalsForDerivedTypeInstantiation(const DerivedTypeSpec &spec) {
const Symbol *IsFinalizable(const Symbol &symbol,
std::set<const DerivedTypeSpec *> *inProgress, bool withImpureFinalizer) {
- if (IsPointer(symbol) || evaluate::IsAssumedRank(symbol)) {
+ if (IsPointer(symbol) || IsAssumedRank(symbol)) {
return nullptr;
}
if (const auto *object{symbol.detailsIf<ObjectEntityDetails>()}) {
@@ -741,7 +741,7 @@ const Symbol *IsFinalizable(const DerivedTypeSpec &derived,
if (const SubprogramDetails *
subp{symbol->detailsIf<SubprogramDetails>()}) {
if (const auto &args{subp->dummyArgs()}; !args.empty() &&
- args.at(0) && !evaluate::IsAssumedRank(*args.at(0)) &&
+ args.at(0) && !IsAssumedRank(*args.at(0)) &&
args.at(0)->Rank() != *rank) {
continue; // not a finalizer for this rank
}
@@ -790,7 +790,7 @@ const Symbol *HasImpureFinal(const Symbol &original, std::optional<int> rank) {
if (symbol.has<ObjectEntityDetails>()) {
if (const DeclTypeSpec * symType{symbol.GetType()}) {
if (const DerivedTypeSpec * derived{symType->AsDerived()}) {
- if (evaluate::IsAssumedRank(symbol)) {
+ if (IsAssumedRank(symbol)) {
// finalizable assumed-rank not allowed (C839)
return nullptr;
} else {
diff --git a/flang/test/Lower/force-temp.f90 b/flang/test/Lower/force-temp.f90
new file mode 100644
index 0000000000000..d9ba543d46313
--- /dev/null
+++ b/flang/test/Lower/force-temp.f90
@@ -0,0 +1,82 @@
+! RUN: bbc -emit-hlfir -o - %s | FileCheck %s
+! Ensure that copy-in/copy-out happens with specific ignore_tkr settings
+module test
+ interface
+ subroutine pass_ignore_tkr(buf)
+ implicit none
+ !DIR$ IGNORE_TKR buf
+ real :: buf
+ end subroutine
+ subroutine pass_ignore_tkr_2(buf)
+ implicit none
+ !DIR$ IGNORE_TKR(tkrdm) buf
+ type(*) :: buf
+ end subroutine
+ subroutine pass_ignore_tkr_c(buf)
+ implicit none
+ !DIR$ IGNORE_TKR (tkrc) buf
+ real :: buf
+ end subroutine
+ subroutine pass_ignore_tkr_c_2(buf)
+ implicit none
+ !DIR$ IGNORE_TKR (tkrcdm) buf
+ type(*) :: buf
+ end subroutine
+ subroutine pass_intent_out(buf)
+ implicit none
+ integer, intent(out) :: buf(5)
+ end subroutine
+ end interface
+contains
+ subroutine s1(buf)
+!CHECK-LABEL: func.func @_QMtestPs1
+!CHECK: hlfir.copy_in
+!CHECK: fir.call @_QPpass_ignore_tkr
+!CHECK: hlfir.copy_out
+ real, intent(inout) :: buf(:)
+ ! Create temp here
+ call pass_ignore_tkr(buf)
+ end subroutine
+ subroutine s2(buf)
+!CHECK-LABEL: func.func @_QMtestPs2
+!CHECK-NOT: hlfir.copy_in
+!CHECK: fir.call @_QPpass_ignore_tkr_c
+!CHECK-NOT: hlfir.copy_out
+ real, intent(inout) :: buf(:)
+ ! Don't create temp here
+ call pass_ignore_tkr_c(buf)
+ end subroutine
+ subroutine s3(buf)
+!CHECK-LABEL: func.func @_QMtestPs3
+!CHECK: hlfir.copy_in
+!CHECK: fir.call @_QPpass_ignore_tkr_2
+!CHECK: hlfir.copy_out
+ real, intent(inout) :: buf(:)
+ ! Create temp here
+ call pass_ignore_tkr_2(buf)
+ end subroutine
+ subroutine s4(buf)
+!CHECK-LABEL: func.func @_QMtestPs4
+!CHECK-NOT: hlfir.copy_in
+!CHECK: fir.call @_QPpass_ignore_tkr_c_2
+!CHECK-NOT: hlfir.copy_out
+ real, intent(inout) :: buf(:)
+ ! Don't create temp here
+ call pass_ignore_tkr_c_2(buf)
+ end subroutine
+ subroutine s5()
+ ! TODO: pass_intent_out() has intent(out) dummy argument, so as such it
+ ! should have copy-out, but not copy-in. Unfortunately, at the moment flang
+ ! can only do copy-in/copy-out together. When this is fixed, this test should
+ ! change from 'CHECK' for hlfir.copy_in to 'CHECK-NOT' for hlfir.copy_in
+!CHECK-LABEL: func.func @_QMtestPs5
+!CHECK: hlfir.copy_in
+!CHECK: fir.call @_QPpass_intent_out
+!CHECK: hlfir.copy_out
+ implicit none
+ integer, target :: x(10)
+ integer, pointer :: p(:)
+ p => x(::2) ! pointer to non-contiguous array section
+ call pass_intent_out(p)
+ end subroutine
+end module
More information about the llvm-branch-commits
mailing list