diff --git a/flang/include/flang/Evaluate/call.h b/flang/include/flang/Evaluate/call.h index 2a5929b873d74..efdcee709d435 100644 --- a/flang/include/flang/Evaluate/call.h +++ b/flang/include/flang/Evaluate/call.h @@ -52,7 +52,7 @@ using SymbolRef = common::Reference; class ActualArgument { public: - ENUM_CLASS(Attr, PassedObject, PercentVal, PercentRef); + ENUM_CLASS(Attr, PassedObject, PercentVal, PercentRef, CopyIn, CopyOut); using Attrs = common::EnumSet; // Dummy arguments that are TYPE(*) can be forwarded as actual arguments. @@ -131,7 +131,6 @@ class ActualArgument { return *this; } - bool Matches(const characteristics::DummyArgument &) const; common::Intent dummyIntent() const { return dummyIntent_; } ActualArgument &set_dummyIntent(common::Intent intent) { dummyIntent_ = intent; @@ -161,6 +160,20 @@ class ActualArgument { return *this; } + // This actual argument may need copy-in before the procedure call + bool GetMayNeedCopyIn() const { return attrs_.test(Attr::CopyIn); }; + ActualArgument &SetMayNeedCopyIn() { + attrs_ = attrs_ + Attr::CopyIn; + return *this; + } + + // This actual argument may need copy-out after the procedure call + bool GetMayNeedCopyOut() const { return attrs_.test(Attr::CopyOut); }; + ActualArgument &SetMayNeedCopyOut() { + attrs_ = attrs_ + Attr::CopyOut; + return *this; + } + private: // Subtlety: There is a distinction that must be maintained here between an // actual argument expression that is a variable and one that is not, @@ -272,6 +285,8 @@ class ProcedureRef { bool operator==(const ProcedureRef &) const; llvm::raw_ostream &AsFortran(llvm::raw_ostream &) const; + void DetermineCopyInOut(); + protected: ProcedureDesignator proc_; ActualArguments arguments_; diff --git a/flang/include/flang/Evaluate/check-expression.h b/flang/include/flang/Evaluate/check-expression.h index eb152652f88c3..7059e03b408c1 100644 --- a/flang/include/flang/Evaluate/check-expression.h +++ b/flang/include/flang/Evaluate/check-expression.h @@ -125,6 +125,9 @@ std::optional IsContiguous(const A &, FoldingContext &, extern template std::optional IsContiguous(const Expr &, FoldingContext &, bool namedConstantSectionsAreContiguous, bool firstDimensionStride1); +extern template std::optional IsContiguous(const ActualArgument &, + FoldingContext &, bool namedConstantSectionsAreContiguous, + bool firstDimensionStride1); extern template std::optional IsContiguous(const ArrayRef &, FoldingContext &, bool namedConstantSectionsAreContiguous, bool firstDimensionStride1); diff --git a/flang/include/flang/Evaluate/shape.h b/flang/include/flang/Evaluate/shape.h index f0505cfcdf2d7..32fcdc0281f26 100644 --- a/flang/include/flang/Evaluate/shape.h +++ b/flang/include/flang/Evaluate/shape.h @@ -35,6 +35,7 @@ using Shape = std::vector; bool IsImpliedShape(const Symbol &); bool IsExplicitShape(const Symbol &); +bool IsExplicitShape(const Shape &); // Conversions between various representations of shapes. std::optional AsExtentArrayExpr(const Shape &); diff --git a/flang/include/flang/Evaluate/tools.h b/flang/include/flang/Evaluate/tools.h index 212356136d6ee..0be3f66321e4f 100644 --- a/flang/include/flang/Evaluate/tools.h +++ b/flang/include/flang/Evaluate/tools.h @@ -1123,6 +1123,7 @@ extern template semantics::UnorderedSymbolSet CollectCudaSymbols( // Predicate: does a variable contain a vector-valued subscript (not a triplet)? bool HasVectorSubscript(const Expr &); +bool HasVectorSubscript(const ActualArgument &); // Predicate: does an expression contain constant? bool HasConstant(const Expr &); diff --git a/flang/lib/Evaluate/call.cpp b/flang/lib/Evaluate/call.cpp index f77df92a7597a..6a69223725b28 100644 --- a/flang/lib/Evaluate/call.cpp +++ b/flang/lib/Evaluate/call.cpp @@ -12,6 +12,7 @@ #include "flang/Evaluate/check-expression.h" #include "flang/Evaluate/expression.h" #include "flang/Evaluate/tools.h" +#include "flang/Semantics/semantics.h" #include "flang/Semantics/symbol.h" #include "flang/Support/Fortran.h" @@ -247,4 +248,163 @@ ProcedureRef::~ProcedureRef() {} void ProcedureRef::Deleter(ProcedureRef *p) { delete p; } +// We don't know the dummy argument info (e.g., procedure with implicit +// interface +static void DetermineCopyInOutArgument( + const characteristics::Procedure &procInfo, ActualArgument &actual, + semantics::SemanticsContext &sc) { + if (actual.isAlternateReturn()) { + return; + } + if (!evaluate::IsVariable(actual)) { + // Actual argument expressions that aren’t variables are copy-in, but + // not copy-out. + actual.SetMayNeedCopyIn(); + } else if (!IsSimplyContiguous(actual, sc.foldingContext())) { + // Actual arguments that are variables are copy-in when non-contiguous. + // They are copy-out when don't have vector subscripts + actual.SetMayNeedCopyIn(); + if (!HasVectorSubscript(actual)) { + actual.SetMayNeedCopyOut(); + } + } else if (ExtractCoarrayRef(actual)) { + // Coindexed actual args need copy-in and copy-out + actual.SetMayNeedCopyIn(); + actual.SetMayNeedCopyOut(); + } +} + +static void DetermineCopyInOutArgument( + const characteristics::Procedure &procInfo, ActualArgument &actual, + characteristics::DummyArgument &dummy, semantics::SemanticsContext &sc) { + assert(procInfo.HasExplicitInterface() && "expect explicit interface proc"); + if (actual.isAlternateReturn()) { + return; + } + const auto *dummyObj{std::get_if(&dummy.u)}; + if (!dummyObj) { + // Only DummyDataObject has the information we need + return; + } + // Pass by value, always copy-in, never copy-out + bool dummyIsValue{ + dummyObj->attrs.test(characteristics::DummyDataObject::Attr::Value)}; + if (dummyIsValue) { + actual.SetMayNeedCopyIn(); + return; + } + bool dummyIntentIn{dummyObj->intent == common::Intent::In}; + bool dummyIntentOut{dummyObj->intent == common::Intent::Out}; + + auto setCopyIn = [&]() { + if (!dummyIntentOut) { + // INTENT(OUT) never need copy-in + actual.SetMayNeedCopyIn(); + } + }; + auto setCopyOut = [&]() { + if (!dummyIntentIn) { + // INTENT(IN) never need copy-out + actual.SetMayNeedCopyOut(); + } + }; + + // Check actual contiguity, unless dummy doesn't care + bool actualTreatAsContiguous{ + dummyObj->ignoreTKR.test(common::IgnoreTKR::Contiguous) || + IsSimplyContiguous(actual, sc.foldingContext())}; + + bool actualHasVectorSubscript{HasVectorSubscript(actual)}; + bool actualIsArray{actual.Rank() > 0}; + + bool dummyIsArray{dummyObj->type.Rank() > 0}; + bool dummyIsExplicitShape{ + dummyIsArray ? IsExplicitShape(*dummyObj->type.shape()) : false}; + bool dummyIsAssumedSize{dummyObj->type.attrs().test( + characteristics::TypeAndShape::Attr::AssumedSize)}; + bool dummyNeedsContiguity{dummyIsArray && + (dummyIsExplicitShape || dummyIsAssumedSize || + dummyObj->attrs.test( + characteristics::DummyDataObject::Attr::Contiguous))}; + if (!actualTreatAsContiguous && dummyNeedsContiguity) { + setCopyIn(); + if (!actualHasVectorSubscript) { + setCopyOut(); + } + return; + } + + // TODO: passing polymorphic to non-polymorphic + + // TODO +} + +void ProcedureRef::DetermineCopyInOut() { + if (!proc_.GetSymbol()) { + return; + } + // Get folding context of the call site owner + semantics::SemanticsContext &sc{proc_.GetSymbol()->owner().context()}; + FoldingContext &fc{sc.foldingContext()}; + auto procInfo{ + characteristics::Procedure::Characterize(proc_, fc, /*emitError=*/true)}; + if (!procInfo) { + return; + } + if (!procInfo->HasExplicitInterface()) { + for (auto &actual : arguments_) { + if (!actual) { + continue; + } + DetermineCopyInOutArgument(*procInfo, *actual, sc); + } + return; + } + // Don't change anything about actual or dummy arguments, except for + // computing copy-in/copy-out information. If detect something wrong with + // the arguments, stop processing and let semantic analysis generate the + // error messages. + size_t index{0}; + std::set processedKeywords; + bool seenKeyword{false}; + for (auto &actual : arguments_) { + if (!actual) { + continue; + } + if (index >= procInfo->dummyArguments.size()) { + // More actual arguments than dummy arguments. Semantic analysis will + // deal with the error. + return; + } + if (actual->keyword()) { + seenKeyword = true; + auto actualName{actual->keyword()->ToString()}; + if (processedKeywords.find(actualName) != processedKeywords.end()) { + // Actual arguments with duplicate keywords. Semantic analysis will + // deal with the error. + return; + } else { + processedKeywords.insert(actualName); + if (auto it{std::find_if(procInfo->dummyArguments.begin(), + procInfo->dummyArguments.end(), + [&](const characteristics::DummyArgument &dummy) { + return dummy.name == actualName; + })}; + it != procInfo->dummyArguments.end()) { + DetermineCopyInOutArgument(*procInfo, *actual, *it, sc); + } + } + } else if (seenKeyword) { + // Non-keyword actual argument after have seen at least one keyword + // actual argument. Semantic analysis will deal with the error. + return; + } else { + // Positional argument processing + DetermineCopyInOutArgument( + *procInfo, *actual, procInfo->dummyArguments[index], sc); + } + ++index; + } +} + } // namespace Fortran::evaluate diff --git a/flang/lib/Evaluate/check-expression.cpp b/flang/lib/Evaluate/check-expression.cpp index 522ab1980f4ee..10361b3b32bc5 100644 --- a/flang/lib/Evaluate/check-expression.cpp +++ b/flang/lib/Evaluate/check-expression.cpp @@ -1282,9 +1282,21 @@ std::optional IsContiguous(const A &x, FoldingContext &context, } } +std::optional IsContiguous(const ActualArgument &actual, + FoldingContext &fc, bool namedConstantSectionsAreContiguous, + bool firstDimensionStride1) { + auto *expr{actual.UnwrapExpr()}; + return expr && + IsContiguous( + *expr, fc, namedConstantSectionsAreContiguous, firstDimensionStride1); +} + template std::optional IsContiguous(const Expr &, FoldingContext &, bool namedConstantSectionsAreContiguous, bool firstDimensionStride1); +template std::optional IsContiguous(const ActualArgument &, + FoldingContext &, bool namedConstantSectionsAreContiguous, + bool firstDimensionStride1); template std::optional IsContiguous(const ArrayRef &, FoldingContext &, bool namedConstantSectionsAreContiguous, bool firstDimensionStride1); template std::optional IsContiguous(const Substring &, FoldingContext &, diff --git a/flang/lib/Evaluate/shape.cpp b/flang/lib/Evaluate/shape.cpp index 776866d1416d2..2c0191e866d3f 100644 --- a/flang/lib/Evaluate/shape.cpp +++ b/flang/lib/Evaluate/shape.cpp @@ -47,6 +47,17 @@ bool IsExplicitShape(const Symbol &original) { } } +bool IsExplicitShape(const Shape &shape) { + // If extent expression is present for all dimensions, then assume + // explicit shape. + for (const auto &dim : shape) { + if (!dim) { + return false; + } + } + return true; +} + Shape GetShapeHelper::ConstantShape(const Constant &arrayConstant) { CHECK(arrayConstant.Rank() == 1); Shape result; diff --git a/flang/lib/Evaluate/tools.cpp b/flang/lib/Evaluate/tools.cpp index 3b2c4f9f56016..6eb910367e0a1 100644 --- a/flang/lib/Evaluate/tools.cpp +++ b/flang/lib/Evaluate/tools.cpp @@ -1203,6 +1203,11 @@ bool HasVectorSubscript(const Expr &expr) { return HasVectorSubscriptHelper{}(expr); } +bool HasVectorSubscript(const ActualArgument &actual) { + auto expr = actual.UnwrapExpr(); + return expr && HasVectorSubscript(*expr); +} + // HasConstant() struct HasConstantHelper : public AnyTraverse { diff --git a/flang/lib/Semantics/expression.cpp b/flang/lib/Semantics/expression.cpp index d022378ce1455..56ae4099c5322 100644 --- a/flang/lib/Semantics/expression.cpp +++ b/flang/lib/Semantics/expression.cpp @@ -3464,6 +3464,7 @@ void ExpressionAnalyzer::Analyze(const parser::CallStmt &callStmt) { HasAlternateReturns(callee->arguments)}, ProcedureRef::Deleter); DEREF(callStmt.typedCall.get()).set_chevrons(std::move(*chevrons)); + DEREF(callStmt.typedCall.get()).DetermineCopyInOut(); return; } }