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 <eepsht...@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 _______________________________________________ llvm-branch-commits mailing list llvm-branch-commits@lists.llvm.org https://lists.llvm.org/cgi-bin/mailman/listinfo/llvm-branch-commits
