[flang-commits] [flang] 8eee236 - [flang] Lower sequence associated argument passed by descriptor (#85696)
via flang-commits
flang-commits at lists.llvm.org
Tue Mar 19 03:26:40 PDT 2024
Author: jeanPerier
Date: 2024-03-19T11:26:36+01:00
New Revision: 8eee236021f72821d628ec31d8e8d1f92e7821d3
URL: https://github.com/llvm/llvm-project/commit/8eee236021f72821d628ec31d8e8d1f92e7821d3
DIFF: https://github.com/llvm/llvm-project/commit/8eee236021f72821d628ec31d8e8d1f92e7821d3.diff
LOG: [flang] Lower sequence associated argument passed by descriptor (#85696)
The current lowering did not handle sequence associated argument passed
by descriptor. This case is special because sequence association implies
that the actual and dummy argument need to to agree in rank and shape.
Usually, arguments that can be sequence associated are passed by raw
address, and the shape mistmatch is transparent. But there are three
cases of explicit and assumed-size arrays passed by descriptors:
- polymorphic arguments
- BIND(C) assumed-length arguments (F'2023 18.3.7 (5)).
- length parametrized derived types (TBD)
The callee side is expecting a descriptor containing the dummy rank and
shape. This was not the case. This patch fix that by evaluating the
dummy shape on the caller side using the interface (that has to be
available when arguments are passed by descriptors).
Added:
flang/test/Lower/HLFIR/call-sequence-associated-descriptors.f90
Modified:
flang/include/flang/Evaluate/characteristics.h
flang/include/flang/Lower/CallInterface.h
flang/include/flang/Lower/ConvertVariable.h
flang/lib/Lower/CallInterface.cpp
flang/lib/Lower/ConvertCall.cpp
flang/lib/Lower/ConvertVariable.cpp
Removed:
################################################################################
diff --git a/flang/include/flang/Evaluate/characteristics.h b/flang/include/flang/Evaluate/characteristics.h
index f2f37866ecde86..82c31c0c404301 100644
--- a/flang/include/flang/Evaluate/characteristics.h
+++ b/flang/include/flang/Evaluate/characteristics.h
@@ -177,6 +177,14 @@ class TypeAndShape {
int corank() const { return corank_; }
int Rank() const { return GetRank(shape_); }
+
+ // Can sequence association apply to this argument?
+ bool CanBeSequenceAssociated() const {
+ constexpr Attrs notAssumedOrExplicitShape{
+ ~Attrs{Attr::AssumedSize, Attr::Coarray}};
+ return Rank() > 0 && (attrs() & notAssumedOrExplicitShape).none();
+ }
+
bool IsCompatibleWith(parser::ContextualMessages &, const TypeAndShape &that,
const char *thisIs = "pointer", const char *thatIs = "target",
bool omitShapeConformanceCheck = false,
diff --git a/flang/include/flang/Lower/CallInterface.h b/flang/include/flang/Lower/CallInterface.h
index e77ac4e179ba86..80b05764253778 100644
--- a/flang/include/flang/Lower/CallInterface.h
+++ b/flang/include/flang/Lower/CallInterface.h
@@ -174,6 +174,12 @@ class CallInterface {
/// May the dummy argument require INTENT(OUT) finalization
/// on entry to the invoked procedure? Provides conservative answer.
bool mayRequireIntentoutFinalization() const;
+ /// Is the dummy argument an explicit-shape or assumed-size array that
+ /// must be passed by descriptor? Sequence association imply the actual
+ /// argument shape/rank may
diff er with the dummy shape/rank (see F'2023
+ /// section 15.5.2.12), so care is needed when creating the descriptor
+ /// for the dummy argument.
+ bool isSequenceAssociatedDescriptor() const;
/// How entity is passed by.
PassEntityBy passBy;
/// What is the entity (SymbolRef for callee/ActualArgument* for caller)
@@ -273,8 +279,6 @@ class CallerInterface : public CallInterface<CallerInterface> {
actualInputs.resize(getNumFIRArguments());
}
- using ExprVisitor = std::function<void(evaluate::Expr<evaluate::SomeType>)>;
-
/// CRTP callbacks
bool hasAlternateReturns() const;
std::string getMangledName() const;
@@ -312,12 +316,21 @@ class CallerInterface : public CallInterface<CallerInterface> {
/// procedure.
const Fortran::semantics::Symbol *getProcedureSymbol() const;
+ /// Return the dummy argument symbol if this is a call to a user
+ /// defined procedure with explicit interface. Returns nullptr if there
+ /// is no user defined explicit interface.
+ const Fortran::semantics::Symbol *
+ getDummySymbol(const PassedEntity &entity) const;
+
/// Helpers to place the lowered arguments at the right place once they
/// have been lowered.
void placeInput(const PassedEntity &passedEntity, mlir::Value arg);
void placeAddressAndLengthInput(const PassedEntity &passedEntity,
mlir::Value addr, mlir::Value len);
+ /// Get lowered FIR argument given the Fortran argument.
+ mlir::Value getInput(const PassedEntity &passedEntity);
+
/// If this is a call to a procedure pointer or dummy, returns the related
/// procedure designator. Nullptr otherwise.
const Fortran::evaluate::ProcedureDesignator *getIfIndirectCall() const;
@@ -333,13 +346,27 @@ class CallerInterface : public CallInterface<CallerInterface> {
/// the result specification expressions (extents and lengths) ? If needed,
/// this mapping must be done after argument lowering, and before the call
/// itself.
- bool mustMapInterfaceSymbols() const;
+ bool mustMapInterfaceSymbolsForResult() const;
+ /// Must the caller map function interface symbols in order to evaluate
+ /// the specification expressions of a given dummy argument?
+ bool mustMapInterfaceSymbolsForDummyArgument(const PassedEntity &) const;
+
+ /// Visitor for specification expression. Boolean indicate the specification
+ /// expression is for the last extent of an assumed size array.
+ using ExprVisitor =
+ std::function<void(evaluate::Expr<evaluate::SomeType>, bool)>;
/// Walk the result non-deferred extent specification expressions.
- void walkResultExtents(ExprVisitor) const;
+ void walkResultExtents(const ExprVisitor &) const;
/// Walk the result non-deferred length specification expressions.
- void walkResultLengths(ExprVisitor) const;
+ void walkResultLengths(const ExprVisitor &) const;
+ /// Walk non-deferred extent specification expressions of a dummy argument.
+ void walkDummyArgumentExtents(const PassedEntity &,
+ const ExprVisitor &) const;
+ /// Walk non-deferred length specification expressions of a dummy argument.
+ void walkDummyArgumentLengths(const PassedEntity &,
+ const ExprVisitor &) const;
/// Get the mlir::Value that is passed as argument \p sym of the function
/// being called. The arguments must have been placed before calling this
@@ -355,6 +382,9 @@ class CallerInterface : public CallInterface<CallerInterface> {
/// returns the storage type.
mlir::Type getResultStorageType() const;
+ /// Return FIR type of argument.
+ mlir::Type getDummyArgumentType(const PassedEntity &) const;
+
// Copy of base implementation.
static constexpr bool hasHostAssociated() { return false; }
mlir::Type getHostAssociatedTy() const {
diff --git a/flang/include/flang/Lower/ConvertVariable.h b/flang/include/flang/Lower/ConvertVariable.h
index b13bb412f0f3e7..ab30e317d1d9d4 100644
--- a/flang/include/flang/Lower/ConvertVariable.h
+++ b/flang/include/flang/Lower/ConvertVariable.h
@@ -93,9 +93,16 @@ void mapSymbolAttributes(AbstractConverter &, const semantics::SymbolRef &,
/// Instantiate the variables that appear in the specification expressions
/// of the result of a function call. The instantiated variables are added
/// to \p symMap.
-void mapCallInterfaceSymbols(AbstractConverter &,
- const Fortran::lower::CallerInterface &caller,
- SymMap &symMap);
+void mapCallInterfaceSymbolsForResult(
+ AbstractConverter &, const Fortran::lower::CallerInterface &caller,
+ SymMap &symMap);
+
+/// Instantiate the variables that appear in the specification expressions
+/// of a dummy argument of a procedure call. The instantiated variables are
+/// added to \p symMap.
+void mapCallInterfaceSymbolsForDummyArgument(
+ AbstractConverter &, const Fortran::lower::CallerInterface &caller,
+ SymMap &symMap, const Fortran::semantics::Symbol &dummySymbol);
// TODO: consider saving the initial expression symbol dependence analysis in
// in the PFT variable and dealing with the dependent symbols instantiation in
diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp
index 6b71aabf7fdc89..2f95d53c383b9a 100644
--- a/flang/lib/Lower/CallInterface.cpp
+++ b/flang/lib/Lower/CallInterface.cpp
@@ -310,21 +310,22 @@ bool Fortran::lower::CallerInterface::verifyActualInputs() const {
return true;
}
-void Fortran::lower::CallerInterface::walkResultLengths(
- ExprVisitor visitor) const {
- assert(characteristic && "characteristic was not computed");
- const Fortran::evaluate::characteristics::FunctionResult &result =
- characteristic->functionResult.value();
- const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape =
- result.GetTypeAndShape();
- assert(typeAndShape && "no result type");
- Fortran::evaluate::DynamicType dynamicType = typeAndShape->type();
- // Visit result length specification expressions that are explicit.
+mlir::Value
+Fortran::lower::CallerInterface::getInput(const PassedEntity &passedEntity) {
+ return actualInputs[passedEntity.firArgument];
+}
+
+static void walkLengths(
+ const Fortran::evaluate::characteristics::TypeAndShape &typeAndShape,
+ const Fortran::lower::CallerInterface::ExprVisitor &visitor,
+ Fortran::lower::AbstractConverter &converter) {
+ Fortran::evaluate::DynamicType dynamicType = typeAndShape.type();
+ // Visit length specification expressions that are explicit.
if (dynamicType.category() == Fortran::common::TypeCategory::Character) {
if (std::optional<Fortran::evaluate::ExtentExpr> length =
dynamicType.GetCharLength())
- visitor(toEvExpr(*length));
- } else if (dynamicType.category() == common::TypeCategory::Derived &&
+ visitor(toEvExpr(*length), /*assumedSize=*/false);
+ } else if (dynamicType.category() == Fortran::common::TypeCategory::Derived &&
!dynamicType.IsUnlimitedPolymorphic()) {
const Fortran::semantics::DerivedTypeSpec &derivedTypeSpec =
dynamicType.GetDerivedTypeSpec();
@@ -334,11 +335,33 @@ void Fortran::lower::CallerInterface::walkResultLengths(
}
}
+void Fortran::lower::CallerInterface::walkResultLengths(
+ const ExprVisitor &visitor) const {
+ assert(characteristic && "characteristic was not computed");
+ const Fortran::evaluate::characteristics::FunctionResult &result =
+ characteristic->functionResult.value();
+ const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape =
+ result.GetTypeAndShape();
+ assert(typeAndShape && "no result type");
+ return walkLengths(*typeAndShape, visitor, converter);
+}
+
+void Fortran::lower::CallerInterface::walkDummyArgumentLengths(
+ const PassedEntity &passedEntity, const ExprVisitor &visitor) const {
+ if (!passedEntity.characteristics)
+ return;
+ if (const auto *dummy =
+ std::get_if<Fortran::evaluate::characteristics::DummyDataObject>(
+ &passedEntity.characteristics->u))
+ walkLengths(dummy->type, visitor, converter);
+}
+
// Compute extent expr from shapeSpec of an explicit shape.
-// TODO: Allow evaluate shape analysis to work in a mode where it disregards
-// the non-constant aspects when building the shape to avoid having this here.
static Fortran::evaluate::ExtentExpr
getExtentExpr(const Fortran::semantics::ShapeSpec &shapeSpec) {
+ if (shapeSpec.ubound().isStar())
+ // F'2023 18.5.3 point 5.
+ return Fortran::evaluate::ExtentExpr{-1};
const auto &ubound = shapeSpec.ubound().GetExplicit();
const auto &lbound = shapeSpec.lbound().GetExplicit();
assert(lbound && ubound && "shape must be explicit");
@@ -346,20 +369,27 @@ getExtentExpr(const Fortran::semantics::ShapeSpec &shapeSpec) {
Fortran::evaluate::ExtentExpr{1};
}
+static void
+walkExtents(const Fortran::semantics::Symbol &symbol,
+ const Fortran::lower::CallerInterface::ExprVisitor &visitor) {
+ if (const auto *objectDetails =
+ symbol.detailsIf<Fortran::semantics::ObjectEntityDetails>())
+ if (objectDetails->shape().IsExplicitShape() ||
+ Fortran::semantics::IsAssumedSizeArray(symbol))
+ for (const Fortran::semantics::ShapeSpec &shapeSpec :
+ objectDetails->shape())
+ visitor(Fortran::evaluate::AsGenericExpr(getExtentExpr(shapeSpec)),
+ /*assumedSize=*/shapeSpec.ubound().isStar());
+}
+
void Fortran::lower::CallerInterface::walkResultExtents(
- ExprVisitor visitor) const {
+ const ExprVisitor &visitor) const {
// Walk directly the result symbol shape (the characteristic shape may contain
// descriptor inquiries to it that would fail to lower on the caller side).
const Fortran::semantics::SubprogramDetails *interfaceDetails =
getInterfaceDetails();
if (interfaceDetails) {
- const Fortran::semantics::Symbol &result = interfaceDetails->result();
- if (const auto *objectDetails =
- result.detailsIf<Fortran::semantics::ObjectEntityDetails>())
- if (objectDetails->shape().IsExplicitShape())
- for (const Fortran::semantics::ShapeSpec &shapeSpec :
- objectDetails->shape())
- visitor(Fortran::evaluate::AsGenericExpr(getExtentExpr(shapeSpec)));
+ walkExtents(interfaceDetails->result(), visitor);
} else {
if (procRef.Rank() != 0)
fir::emitFatalError(
@@ -368,7 +398,18 @@ void Fortran::lower::CallerInterface::walkResultExtents(
}
}
-bool Fortran::lower::CallerInterface::mustMapInterfaceSymbols() const {
+void Fortran::lower::CallerInterface::walkDummyArgumentExtents(
+ const PassedEntity &passedEntity, const ExprVisitor &visitor) const {
+ const Fortran::semantics::SubprogramDetails *interfaceDetails =
+ getInterfaceDetails();
+ if (!interfaceDetails)
+ return;
+ const Fortran::semantics::Symbol *dummy = getDummySymbol(passedEntity);
+ assert(dummy && "dummy symbol was not set");
+ walkExtents(*dummy, visitor);
+}
+
+bool Fortran::lower::CallerInterface::mustMapInterfaceSymbolsForResult() const {
assert(characteristic && "characteristic was not computed");
const std::optional<Fortran::evaluate::characteristics::FunctionResult>
&result = characteristic->functionResult;
@@ -376,7 +417,7 @@ bool Fortran::lower::CallerInterface::mustMapInterfaceSymbols() const {
!getInterfaceDetails() || result->IsProcedurePointer())
return false;
bool allResultSpecExprConstant = true;
- auto visitor = [&](const Fortran::lower::SomeExpr &e) {
+ auto visitor = [&](const Fortran::lower::SomeExpr &e, bool) {
allResultSpecExprConstant &= Fortran::evaluate::IsConstantExpr(e);
};
walkResultLengths(visitor);
@@ -384,6 +425,17 @@ bool Fortran::lower::CallerInterface::mustMapInterfaceSymbols() const {
return !allResultSpecExprConstant;
}
+bool Fortran::lower::CallerInterface::mustMapInterfaceSymbolsForDummyArgument(
+ const PassedEntity &arg) const {
+ bool allResultSpecExprConstant = true;
+ auto visitor = [&](const Fortran::lower::SomeExpr &e, bool) {
+ allResultSpecExprConstant &= Fortran::evaluate::IsConstantExpr(e);
+ };
+ walkDummyArgumentLengths(arg, visitor);
+ walkDummyArgumentExtents(arg, visitor);
+ return !allResultSpecExprConstant;
+}
+
mlir::Value Fortran::lower::CallerInterface::getArgumentValue(
const semantics::Symbol &sym) const {
mlir::Location loc = converter.getCurrentLocation();
@@ -401,6 +453,24 @@ mlir::Value Fortran::lower::CallerInterface::getArgumentValue(
return actualInputs[mlirArgIndex];
}
+const Fortran::semantics::Symbol *
+Fortran::lower::CallerInterface::getDummySymbol(
+ const PassedEntity &passedEntity) const {
+ const Fortran::semantics::SubprogramDetails *ifaceDetails =
+ getInterfaceDetails();
+ if (!ifaceDetails)
+ return nullptr;
+ std::size_t argPosition = 0;
+ for (const auto &arg : getPassedArguments()) {
+ if (&arg == &passedEntity)
+ break;
+ ++argPosition;
+ }
+ if (argPosition >= ifaceDetails->dummyArgs().size())
+ return nullptr;
+ return ifaceDetails->dummyArgs()[argPosition];
+}
+
mlir::Type Fortran::lower::CallerInterface::getResultStorageType() const {
if (passedResult)
return fir::dyn_cast_ptrEleTy(inputs[passedResult->firArgument].type);
@@ -408,6 +478,11 @@ mlir::Type Fortran::lower::CallerInterface::getResultStorageType() const {
return outputs[0].type;
}
+mlir::Type Fortran::lower::CallerInterface::getDummyArgumentType(
+ const PassedEntity &passedEntity) const {
+ return inputs[passedEntity.firArgument].type;
+}
+
const Fortran::semantics::Symbol &
Fortran::lower::CallerInterface::getResultSymbol() const {
mlir::Location loc = converter.getCurrentLocation();
@@ -1387,6 +1462,17 @@ bool Fortran::lower::CallInterface<
return Fortran::semantics::IsFinalizable(*derived);
}
+template <typename T>
+bool Fortran::lower::CallInterface<
+ T>::PassedEntity::isSequenceAssociatedDescriptor() const {
+ if (!characteristics || passBy != PassEntityBy::Box)
+ return false;
+ const auto *dummy =
+ std::get_if<Fortran::evaluate::characteristics::DummyDataObject>(
+ &characteristics->u);
+ return dummy && dummy->type.CanBeSequenceAssociated();
+}
+
template <typename T>
void Fortran::lower::CallInterface<T>::determineInterface(
bool isImplicit,
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index 95569337a06e90..6eba243c237cf2 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -164,6 +164,125 @@ static mlir::Value readDim3Value(fir::FirOpBuilder &builder, mlir::Location loc,
return hlfir::loadTrivialScalar(loc, builder, hlfir::Entity{designate});
}
+static mlir::Value remapActualToDummyDescriptor(
+ mlir::Location loc, Fortran::lower::AbstractConverter &converter,
+ Fortran::lower::SymMap &symMap,
+ const Fortran::lower::CallerInterface::PassedEntity &arg,
+ Fortran::lower::CallerInterface &caller, bool isBindcCall) {
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ mlir::IndexType idxTy = builder.getIndexType();
+ mlir::Value zero = builder.createIntegerConstant(loc, idxTy, 0);
+ Fortran::lower::StatementContext localStmtCtx;
+ auto lowerSpecExpr = [&](const auto &expr,
+ bool isAssumedSizeExtent) -> mlir::Value {
+ mlir::Value convertExpr = builder.createConvert(
+ loc, idxTy, fir::getBase(converter.genExprValue(expr, localStmtCtx)));
+ if (isAssumedSizeExtent)
+ return convertExpr;
+ return fir::factory::genMaxWithZero(builder, loc, convertExpr);
+ };
+ bool mapSymbols = caller.mustMapInterfaceSymbolsForDummyArgument(arg);
+ if (mapSymbols) {
+ symMap.pushScope();
+ const Fortran::semantics::Symbol *sym = caller.getDummySymbol(arg);
+ assert(sym && "call must have explicit interface to map interface symbols");
+ Fortran::lower::mapCallInterfaceSymbolsForDummyArgument(converter, caller,
+ symMap, *sym);
+ }
+ llvm::SmallVector<mlir::Value> extents;
+ llvm::SmallVector<mlir::Value> lengths;
+ mlir::Type dummyBoxType = caller.getDummyArgumentType(arg);
+ mlir::Type dummyBaseType = fir::unwrapPassByRefType(dummyBoxType);
+ if (dummyBaseType.isa<fir::SequenceType>())
+ caller.walkDummyArgumentExtents(
+ arg, [&](const Fortran::lower::SomeExpr &e, bool isAssumedSizeExtent) {
+ extents.emplace_back(lowerSpecExpr(e, isAssumedSizeExtent));
+ });
+ mlir::Value shape;
+ if (!extents.empty()) {
+ if (isBindcCall) {
+ // Preserve zero lower bounds (see F'2023 18.5.3).
+ llvm::SmallVector<mlir::Value> lowerBounds(extents.size(), zero);
+ shape = builder.genShape(loc, lowerBounds, extents);
+ } else {
+ shape = builder.genShape(loc, extents);
+ }
+ }
+
+ hlfir::Entity explicitArgument = hlfir::Entity{caller.getInput(arg)};
+ mlir::Type dummyElementType = fir::unwrapSequenceType(dummyBaseType);
+ if (auto recType = llvm::dyn_cast<fir::RecordType>(dummyElementType))
+ if (recType.getNumLenParams() > 0)
+ TODO(loc, "sequence association of length parameterized derived type "
+ "dummy arguments");
+ if (fir::isa_char(dummyElementType))
+ lengths.emplace_back(hlfir::genCharLength(loc, builder, explicitArgument));
+ mlir::Value baseAddr =
+ hlfir::genVariableRawAddress(loc, builder, explicitArgument);
+ baseAddr = builder.createConvert(loc, fir::ReferenceType::get(dummyBaseType),
+ baseAddr);
+ mlir::Value mold;
+ if (fir::isPolymorphicType(dummyBoxType))
+ mold = explicitArgument;
+ mlir::Value remapped =
+ builder.create<fir::EmboxOp>(loc, dummyBoxType, baseAddr, shape,
+ /*slice=*/mlir::Value{}, lengths, mold);
+ if (mapSymbols)
+ symMap.popScope();
+ return remapped;
+}
+
+/// Create a descriptor for sequenced associated descriptor that are passed
+/// by descriptor. Sequence association (F'2023 15.5.2.12) implies that the
+/// dummy shape and rank need to not be the same as the actual argument. This
+/// helper creates a descriptor based on the dummy shape and rank (sequence
+/// association can only happen with explicit and assumed-size array) so that it
+/// is safe to assume the rank of the incoming descriptor inside the callee.
+/// This helper must be called once all the actual arguments have been lowered
+/// and placed inside "caller". Copy-in/copy-out must already have been
+/// generated if needed using the actual argument shape (the dummy shape may be
+/// assumed-size).
+static void remapActualToDummyDescriptors(
+ mlir::Location loc, Fortran::lower::AbstractConverter &converter,
+ Fortran::lower::SymMap &symMap,
+ const Fortran::lower::PreparedActualArguments &loweredActuals,
+ Fortran::lower::CallerInterface &caller, bool isBindcCall) {
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ for (auto [preparedActual, arg] :
+ llvm::zip(loweredActuals, caller.getPassedArguments())) {
+ if (arg.isSequenceAssociatedDescriptor()) {
+ if (!preparedActual.value().handleDynamicOptional()) {
+ mlir::Value remapped = remapActualToDummyDescriptor(
+ loc, converter, symMap, arg, caller, isBindcCall);
+ caller.placeInput(arg, remapped);
+ } else {
+ // Absent optional actual argument descriptor cannot be read and
+ // remapped unconditionally.
+ mlir::Type dummyType = caller.getDummyArgumentType(arg);
+ mlir::Value isPresent = preparedActual.value().getIsPresent();
+ auto &argLambdaCapture = arg;
+ mlir::Value remapped =
+ builder
+ .genIfOp(loc, {dummyType}, isPresent,
+ /*withElseRegion=*/true)
+ .genThen([&]() {
+ mlir::Value newBox = remapActualToDummyDescriptor(
+ loc, converter, symMap, argLambdaCapture, caller,
+ isBindcCall);
+ builder.create<fir::ResultOp>(loc, newBox);
+ })
+ .genElse([&]() {
+ mlir::Value absent =
+ builder.create<fir::AbsentOp>(loc, dummyType);
+ builder.create<fir::ResultOp>(loc, absent);
+ })
+ .getResults()[0];
+ caller.placeInput(arg, remapped);
+ }
+ }
+ }
+}
+
std::pair<fir::ExtendedValue, bool> Fortran::lower::genCallOpAndResult(
mlir::Location loc, Fortran::lower::AbstractConverter &converter,
Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx,
@@ -171,12 +290,11 @@ std::pair<fir::ExtendedValue, bool> Fortran::lower::genCallOpAndResult(
std::optional<mlir::Type> resultType, bool isElemental) {
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
using PassBy = Fortran::lower::CallerInterface::PassEntityBy;
- // Handle cases where caller must allocate the result or a fir.box for it.
bool mustPopSymMap = false;
- if (caller.mustMapInterfaceSymbols()) {
+ if (caller.mustMapInterfaceSymbolsForResult()) {
symMap.pushScope();
mustPopSymMap = true;
- Fortran::lower::mapCallInterfaceSymbols(converter, caller, symMap);
+ Fortran::lower::mapCallInterfaceSymbolsForResult(converter, caller, symMap);
}
// If this is an indirect call, retrieve the function address. Also retrieve
// the result length if this is a character function (note that this length
@@ -221,12 +339,16 @@ std::pair<fir::ExtendedValue, bool> Fortran::lower::genCallOpAndResult(
return {};
mlir::Type type = caller.getResultStorageType();
if (type.isa<fir::SequenceType>())
- caller.walkResultExtents([&](const Fortran::lower::SomeExpr &e) {
- extents.emplace_back(lowerSpecExpr(e));
- });
- caller.walkResultLengths([&](const Fortran::lower::SomeExpr &e) {
- lengths.emplace_back(lowerSpecExpr(e));
- });
+ caller.walkResultExtents(
+ [&](const Fortran::lower::SomeExpr &e, bool isAssumedSizeExtent) {
+ assert(!isAssumedSizeExtent && "result cannot be assumed-size");
+ extents.emplace_back(lowerSpecExpr(e));
+ });
+ caller.walkResultLengths(
+ [&](const Fortran::lower::SomeExpr &e, bool isAssumedSizeExtent) {
+ assert(!isAssumedSizeExtent && "result cannot be assumed-size");
+ lengths.emplace_back(lowerSpecExpr(e));
+ });
// Result length parameters should not be provided to box storage
// allocation and save_results, but they are still useful information to
@@ -1056,10 +1178,16 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
// Create dummy type with actual argument rank when the dummy is an assumed
// rank. That way, all the operation to create dummy descriptors are ranked if
// the actual argument is ranked, which allows simple code generation.
+ // Also do the same when the dummy is a sequence associated descriptor
+ // because the actual shape/rank may mismatch with the dummy, and the dummy
+ // may be an assumed-size array, so any descriptor manipulation should use the
+ // actual argument shape information. A descriptor with the dummy shape
+ // information will be created later when all actual arguments are ready.
mlir::Type dummyTypeWithActualRank = dummyType;
if (auto baseBoxDummy = mlir::dyn_cast<fir::BaseBoxType>(dummyType))
if (baseBoxDummy.isAssumedRank() ||
- arg.testTKR(Fortran::common::IgnoreTKR::Rank))
+ arg.testTKR(Fortran::common::IgnoreTKR::Rank) ||
+ arg.isSequenceAssociatedDescriptor())
dummyTypeWithActualRank =
baseBoxDummy.getBoxTypeWithNewShape(actual.getType());
// Preserve the actual type in the argument preparation in case IgnoreTKR(t)
@@ -1342,6 +1470,7 @@ genUserCall(Fortran::lower::PreparedActualArguments &loweredActuals,
mlir::FunctionType callSiteType, CallContext &callContext) {
using PassBy = Fortran::lower::CallerInterface::PassEntityBy;
mlir::Location loc = callContext.loc;
+ bool mustRemapActualToDummyDescriptors = false;
fir::FirOpBuilder &builder = callContext.getBuilder();
llvm::SmallVector<CallCleanUp> callCleanUps;
for (auto [preparedActual, arg] :
@@ -1398,6 +1527,9 @@ genUserCall(Fortran::lower::PreparedActualArguments &loweredActuals,
callCleanUps.append(preparedDummy.cleanups.rbegin(),
preparedDummy.cleanups.rend());
caller.placeInput(arg, preparedDummy.dummy);
+ if (arg.passBy == PassBy::Box)
+ mustRemapActualToDummyDescriptors |=
+ arg.isSequenceAssociatedDescriptor();
} break;
case PassBy::BoxProcRef: {
PreparedDummyArgument preparedDummy =
@@ -1490,6 +1622,12 @@ genUserCall(Fortran::lower::PreparedActualArguments &loweredActuals,
} break;
}
}
+ // Handle cases where caller must allocate the result or a fir.box for it.
+ if (mustRemapActualToDummyDescriptors)
+ remapActualToDummyDescriptors(loc, callContext.converter,
+ callContext.symMap, loweredActuals, caller,
+ callContext.isBindcCall());
+
// Prepare lowered arguments according to the interface
// and map the lowered values to the dummy
// arguments.
diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp
index a673a18cd20d91..94d849862099eb 100644
--- a/flang/lib/Lower/ConvertVariable.cpp
+++ b/flang/lib/Lower/ConvertVariable.cpp
@@ -2260,19 +2260,20 @@ void Fortran::lower::instantiateVariable(AbstractConverter &converter,
instantiateLocal(converter, var, symMap);
}
-void Fortran::lower::mapCallInterfaceSymbols(
- AbstractConverter &converter, const Fortran::lower::CallerInterface &caller,
- SymMap &symMap) {
+static void
+mapCallInterfaceSymbol(const Fortran::semantics::Symbol &interfaceSymbol,
+ Fortran::lower::AbstractConverter &converter,
+ const Fortran::lower::CallerInterface &caller,
+ Fortran::lower::SymMap &symMap) {
Fortran::lower::AggregateStoreMap storeMap;
- const Fortran::semantics::Symbol &result = caller.getResultSymbol();
for (Fortran::lower::pft::Variable var :
- Fortran::lower::pft::getDependentVariableList(result)) {
+ Fortran::lower::pft::getDependentVariableList(interfaceSymbol)) {
if (var.isAggregateStore()) {
instantiateVariable(converter, var, symMap, storeMap);
continue;
}
const Fortran::semantics::Symbol &sym = var.getSymbol();
- if (&sym == &result)
+ if (&sym == &interfaceSymbol)
continue;
const auto *hostDetails =
sym.detailsIf<Fortran::semantics::HostAssocDetails>();
@@ -2293,7 +2294,8 @@ void Fortran::lower::mapCallInterfaceSymbols(
// instantiateVariable that would try to allocate a new storage.
continue;
}
- if (Fortran::semantics::IsDummy(sym) && sym.owner() == result.owner()) {
+ if (Fortran::semantics::IsDummy(sym) &&
+ sym.owner() == interfaceSymbol.owner()) {
// Get the argument for the dummy argument symbols of the current call.
symMap.addSymbol(sym, caller.getArgumentValue(sym));
// All the properties of the dummy variable may not come from the actual
@@ -2307,6 +2309,19 @@ void Fortran::lower::mapCallInterfaceSymbols(
}
}
+void Fortran::lower::mapCallInterfaceSymbolsForResult(
+ AbstractConverter &converter, const Fortran::lower::CallerInterface &caller,
+ SymMap &symMap) {
+ const Fortran::semantics::Symbol &result = caller.getResultSymbol();
+ mapCallInterfaceSymbol(result, converter, caller, symMap);
+}
+
+void Fortran::lower::mapCallInterfaceSymbolsForDummyArgument(
+ AbstractConverter &converter, const Fortran::lower::CallerInterface &caller,
+ SymMap &symMap, const Fortran::semantics::Symbol &dummySymbol) {
+ mapCallInterfaceSymbol(dummySymbol, converter, caller, symMap);
+}
+
void Fortran::lower::mapSymbolAttributes(
AbstractConverter &converter, const Fortran::semantics::SymbolRef &symbol,
Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx,
diff --git a/flang/test/Lower/HLFIR/call-sequence-associated-descriptors.f90 b/flang/test/Lower/HLFIR/call-sequence-associated-descriptors.f90
new file mode 100644
index 00000000000000..9cbb9279a868de
--- /dev/null
+++ b/flang/test/Lower/HLFIR/call-sequence-associated-descriptors.f90
@@ -0,0 +1,309 @@
+! Test lowering of sequence associated arguments (F'2023 15.5.2.12) passed
+! by descriptor. The descriptor on the caller side is prepared according to
+! the dummy argument shape.
+! RUN: bbc -emit-hlfir -polymorphic-type -o - %s | FileCheck %s
+
+module bindc_seq_assoc
+ interface
+ subroutine takes_char(x, n) bind(c)
+ integer :: n
+ character(*) :: x(n)
+ end subroutine
+ subroutine takes_char_assumed_size(x) bind(c)
+ character(*) :: x(10, *)
+ end subroutine
+ subroutine takes_optional_char(x, n) bind(c)
+ integer :: n
+ character(*), optional :: x(n)
+ end subroutine
+ end interface
+contains
+ subroutine test_char_1(x)
+ character(*) :: x(10, 20)
+ call takes_char(x, 100)
+ end subroutine
+! CHECK-LABEL: func.func @_QMbindc_seq_assocPtest_char_1(
+! CHECK: %[[VAL_6:.*]]:2 = hlfir.declare %[[VAL_2:.*]](%[[VAL_5:.*]]) typeparams %[[VAL_1:.*]]#1 {uniq_name = "_QMbindc_seq_assocFtest_char_1Ex"} : (!fir.ref<!fir.array<10x20x!fir.char<1,?>>>, !fir.shape<2>, index) -> (!fir.box<!fir.array<10x20x!fir.char<1,?>>>, !fir.ref<!fir.array<10x20x!fir.char<1,?>>>)
+! CHECK: %[[VAL_7:.*]] = arith.constant 100 : i32
+! CHECK: %[[VAL_8:.*]] = arith.constant 0 : index
+! CHECK: %[[VAL_9:.*]] = fir.shift %[[VAL_8]], %[[VAL_8]] : (index, index) -> !fir.shift<2>
+! CHECK: %[[VAL_10:.*]] = fir.rebox %[[VAL_6]]#0(%[[VAL_9]]) : (!fir.box<!fir.array<10x20x!fir.char<1,?>>>, !fir.shift<2>) -> !fir.box<!fir.array<10x20x!fir.char<1,?>>>
+! CHECK: %[[VAL_11:.*]]:3 = hlfir.associate %[[VAL_7]] {adapt.valuebyref} : (i32) -> (!fir.ref<i32>, !fir.ref<i32>, i1)
+! CHECK: %[[VAL_12:.*]] = arith.constant 0 : index
+! CHECK: %[[VAL_13:.*]]:2 = hlfir.declare %[[VAL_11]]#1 {uniq_name = "_QMbindc_seq_assocFtakes_charEn"} : (!fir.ref<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
+! CHECK: %[[VAL_14:.*]] = fir.load %[[VAL_13]]#0 : !fir.ref<i32>
+! CHECK: %[[VAL_15:.*]] = fir.convert %[[VAL_14]] : (i32) -> i64
+! CHECK: %[[VAL_16:.*]] = arith.constant 1 : i64
+! CHECK: %[[VAL_17:.*]] = arith.subi %[[VAL_15]], %[[VAL_16]] : i64
+! CHECK: %[[VAL_18:.*]] = arith.constant 1 : i64
+! CHECK: %[[VAL_19:.*]] = arith.addi %[[VAL_17]], %[[VAL_18]] : i64
+! CHECK: %[[VAL_20:.*]] = fir.convert %[[VAL_19]] : (i64) -> index
+! CHECK: %[[VAL_21:.*]] = arith.constant 0 : index
+! CHECK: %[[VAL_22:.*]] = arith.cmpi sgt, %[[VAL_20]], %[[VAL_21]] : index
+! CHECK: %[[VAL_23:.*]] = arith.select %[[VAL_22]], %[[VAL_20]], %[[VAL_21]] : index
+! CHECK: %[[VAL_24:.*]] = fir.shape_shift %[[VAL_12]], %[[VAL_23]] : (index, index) -> !fir.shapeshift<1>
+! CHECK: %[[VAL_25:.*]] = fir.box_elesize %[[VAL_10]] : (!fir.box<!fir.array<10x20x!fir.char<1,?>>>) -> index
+! CHECK: %[[VAL_26:.*]] = fir.box_addr %[[VAL_10]] : (!fir.box<!fir.array<10x20x!fir.char<1,?>>>) -> !fir.ref<!fir.array<10x20x!fir.char<1,?>>>
+! CHECK: %[[VAL_27:.*]] = fir.convert %[[VAL_26]] : (!fir.ref<!fir.array<10x20x!fir.char<1,?>>>) -> !fir.ref<!fir.array<?x!fir.char<1,?>>>
+! CHECK: %[[VAL_28:.*]] = fir.embox %[[VAL_27]](%[[VAL_24]]) typeparams %[[VAL_25]] : (!fir.ref<!fir.array<?x!fir.char<1,?>>>, !fir.shapeshift<1>, index) -> !fir.box<!fir.array<?x!fir.char<1,?>>>
+! CHECK: fir.call @takes_char(%[[VAL_28]], %[[VAL_11]]#1) fastmath<contract> : (!fir.box<!fir.array<?x!fir.char<1,?>>>, !fir.ref<i32>) -> ()
+! CHECK: hlfir.end_associate %[[VAL_11]]#1, %[[VAL_11]]#2 : !fir.ref<i32>, i1
+! CHECK: return
+! CHECK: }
+
+ subroutine test_char_copy_in_copy_out(x)
+ character(*) :: x(:, :)
+ call takes_char(x, 100)
+ end subroutine
+! CHECK-LABEL: func.func @_QMbindc_seq_assocPtest_char_copy_in_copy_out(
+! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:.*]] {uniq_name = "_QMbindc_seq_assocFtest_char_copy_in_copy_outEx"} : (!fir.box<!fir.array<?x?x!fir.char<1,?>>>) -> (!fir.box<!fir.array<?x?x!fir.char<1,?>>>, !fir.box<!fir.array<?x?x!fir.char<1,?>>>)
+! CHECK: %[[VAL_2:.*]] = arith.constant 100 : i32
+! CHECK: %[[VAL_3:.*]]:2 = hlfir.copy_in %[[VAL_1]]#0 : (!fir.box<!fir.array<?x?x!fir.char<1,?>>>) -> (!fir.box<!fir.array<?x?x!fir.char<1,?>>>, i1)
+! CHECK: %[[VAL_4:.*]] = arith.constant 0 : index
+! CHECK: %[[VAL_5:.*]] = fir.shift %[[VAL_4]], %[[VAL_4]] : (index, index) -> !fir.shift<2>
+! CHECK: %[[VAL_6:.*]] = fir.rebox %[[VAL_3]]#0(%[[VAL_5]]) : (!fir.box<!fir.array<?x?x!fir.char<1,?>>>, !fir.shift<2>) -> !fir.box<!fir.array<?x?x!fir.char<1,?>>>
+! CHECK: %[[VAL_7:.*]]:3 = hlfir.associate %[[VAL_2]] {adapt.valuebyref} : (i32) -> (!fir.ref<i32>, !fir.ref<i32>, i1)
+! CHECK: %[[VAL_8:.*]] = arith.constant 0 : index
+! CHECK: %[[VAL_9:.*]]:2 = hlfir.declare %[[VAL_7]]#1 {uniq_name = "_QMbindc_seq_assocFtakes_charEn"} : (!fir.ref<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
+! CHECK: %[[VAL_10:.*]] = fir.load %[[VAL_9]]#0 : !fir.ref<i32>
+! CHECK: %[[VAL_11:.*]] = fir.convert %[[VAL_10]] : (i32) -> i64
+! CHECK: %[[VAL_12:.*]] = arith.constant 1 : i64
+! CHECK: %[[VAL_13:.*]] = arith.subi %[[VAL_11]], %[[VAL_12]] : i64
+! CHECK: %[[VAL_14:.*]] = arith.constant 1 : i64
+! CHECK: %[[VAL_15:.*]] = arith.addi %[[VAL_13]], %[[VAL_14]] : i64
+! CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_15]] : (i64) -> index
+! CHECK: %[[VAL_17:.*]] = arith.constant 0 : index
+! CHECK: %[[VAL_18:.*]] = arith.cmpi sgt, %[[VAL_16]], %[[VAL_17]] : index
+! CHECK: %[[VAL_19:.*]] = arith.select %[[VAL_18]], %[[VAL_16]], %[[VAL_17]] : index
+! CHECK: %[[VAL_20:.*]] = fir.shape_shift %[[VAL_8]], %[[VAL_19]] : (index, index) -> !fir.shapeshift<1>
+! CHECK: %[[VAL_21:.*]] = fir.box_elesize %[[VAL_6]] : (!fir.box<!fir.array<?x?x!fir.char<1,?>>>) -> index
+! CHECK: %[[VAL_22:.*]] = fir.box_addr %[[VAL_6]] : (!fir.box<!fir.array<?x?x!fir.char<1,?>>>) -> !fir.ref<!fir.array<?x?x!fir.char<1,?>>>
+! CHECK: %[[VAL_23:.*]] = fir.convert %[[VAL_22]] : (!fir.ref<!fir.array<?x?x!fir.char<1,?>>>) -> !fir.ref<!fir.array<?x!fir.char<1,?>>>
+! CHECK: %[[VAL_24:.*]] = fir.embox %[[VAL_23]](%[[VAL_20]]) typeparams %[[VAL_21]] : (!fir.ref<!fir.array<?x!fir.char<1,?>>>, !fir.shapeshift<1>, index) -> !fir.box<!fir.array<?x!fir.char<1,?>>>
+! CHECK: fir.call @takes_char(%[[VAL_24]], %[[VAL_7]]#1) fastmath<contract> : (!fir.box<!fir.array<?x!fir.char<1,?>>>, !fir.ref<i32>) -> ()
+! CHECK: hlfir.copy_out %[[VAL_3]]#0, %[[VAL_3]]#1 to %[[VAL_1]]#0 : (!fir.box<!fir.array<?x?x!fir.char<1,?>>>, i1, !fir.box<!fir.array<?x?x!fir.char<1,?>>>) -> ()
+! CHECK: hlfir.end_associate %[[VAL_7]]#1, %[[VAL_7]]#2 : !fir.ref<i32>, i1
+! CHECK: return
+! CHECK: }
+
+ subroutine test_char_assumed_size(x)
+ character(*) :: x(:, :)
+ call takes_char_assumed_size(x)
+ end subroutine
+! CHECK-LABEL: func.func @_QMbindc_seq_assocPtest_char_assumed_size(
+! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:.*]] {uniq_name = "_QMbindc_seq_assocFtest_char_assumed_sizeEx"} : (!fir.box<!fir.array<?x?x!fir.char<1,?>>>) -> (!fir.box<!fir.array<?x?x!fir.char<1,?>>>, !fir.box<!fir.array<?x?x!fir.char<1,?>>>)
+! CHECK: %[[VAL_2:.*]]:2 = hlfir.copy_in %[[VAL_1]]#0 : (!fir.box<!fir.array<?x?x!fir.char<1,?>>>) -> (!fir.box<!fir.array<?x?x!fir.char<1,?>>>, i1)
+! CHECK: %[[VAL_3:.*]] = arith.constant 0 : index
+! CHECK: %[[VAL_4:.*]] = fir.shift %[[VAL_3]], %[[VAL_3]] : (index, index) -> !fir.shift<2>
+! CHECK: %[[VAL_5:.*]] = fir.rebox %[[VAL_2]]#0(%[[VAL_4]]) : (!fir.box<!fir.array<?x?x!fir.char<1,?>>>, !fir.shift<2>) -> !fir.box<!fir.array<?x?x!fir.char<1,?>>>
+! CHECK: %[[VAL_6:.*]] = arith.constant 0 : index
+! CHECK: %[[VAL_7:.*]] = arith.constant 10 : i64
+! CHECK: %[[VAL_8:.*]] = arith.constant 1 : i64
+! CHECK: %[[VAL_9:.*]] = arith.subi %[[VAL_7]], %[[VAL_8]] : i64
+! CHECK: %[[VAL_10:.*]] = arith.constant 1 : i64
+! CHECK: %[[VAL_11:.*]] = arith.addi %[[VAL_9]], %[[VAL_10]] : i64
+! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (i64) -> index
+! CHECK: %[[VAL_13:.*]] = arith.constant 0 : index
+! CHECK: %[[VAL_14:.*]] = arith.cmpi sgt, %[[VAL_12]], %[[VAL_13]] : index
+! CHECK: %[[VAL_15:.*]] = arith.select %[[VAL_14]], %[[VAL_12]], %[[VAL_13]] : index
+! CHECK: %[[VAL_16:.*]] = arith.constant -1 : i64
+! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_16]] : (i64) -> index
+! CHECK: %[[VAL_18:.*]] = fir.shape_shift %[[VAL_6]], %[[VAL_15]], %[[VAL_6]], %[[VAL_17]] : (index, index, index, index) -> !fir.shapeshift<2>
+! CHECK: %[[VAL_19:.*]] = fir.box_elesize %[[VAL_5]] : (!fir.box<!fir.array<?x?x!fir.char<1,?>>>) -> index
+! CHECK: %[[VAL_20:.*]] = fir.box_addr %[[VAL_5]] : (!fir.box<!fir.array<?x?x!fir.char<1,?>>>) -> !fir.ref<!fir.array<?x?x!fir.char<1,?>>>
+! CHECK: %[[VAL_21:.*]] = fir.convert %[[VAL_20]] : (!fir.ref<!fir.array<?x?x!fir.char<1,?>>>) -> !fir.ref<!fir.array<10x?x!fir.char<1,?>>>
+! CHECK: %[[VAL_22:.*]] = fir.embox %[[VAL_21]](%[[VAL_18]]) typeparams %[[VAL_19]] : (!fir.ref<!fir.array<10x?x!fir.char<1,?>>>, !fir.shapeshift<2>, index) -> !fir.box<!fir.array<10x?x!fir.char<1,?>>>
+! CHECK: fir.call @takes_char_assumed_size(%[[VAL_22]]) fastmath<contract> : (!fir.box<!fir.array<10x?x!fir.char<1,?>>>) -> ()
+! CHECK: hlfir.copy_out %[[VAL_2]]#0, %[[VAL_2]]#1 to %[[VAL_1]]#0 : (!fir.box<!fir.array<?x?x!fir.char<1,?>>>, i1, !fir.box<!fir.array<?x?x!fir.char<1,?>>>) -> ()
+! CHECK: return
+! CHECK: }
+
+ subroutine test_optional_char(x)
+ character(*), optional :: x(10, 20)
+ call takes_optional_char(x, 100)
+ end subroutine
+! CHECK-LABEL: func.func @_QMbindc_seq_assocPtest_optional_char(
+! CHECK: %[[VAL_6:.*]]:2 = hlfir.declare %[[VAL_2:.*]](%[[VAL_5:.*]]) typeparams %[[VAL_1:.*]]#1 {fortran_attrs = #fir.var_attrs<optional>, uniq_name = "_QMbindc_seq_assocFtest_optional_charEx"} : (!fir.ref<!fir.array<10x20x!fir.char<1,?>>>, !fir.shape<2>, index) -> (!fir.box<!fir.array<10x20x!fir.char<1,?>>>, !fir.ref<!fir.array<10x20x!fir.char<1,?>>>)
+! CHECK: %[[VAL_7:.*]] = fir.is_present %[[VAL_6]]#0 : (!fir.box<!fir.array<10x20x!fir.char<1,?>>>) -> i1
+! CHECK: %[[VAL_8:.*]] = arith.constant 100 : i32
+! CHECK: %[[VAL_9:.*]] = fir.if %[[VAL_7]] -> (!fir.box<!fir.array<10x20x!fir.char<1,?>>>) {
+! CHECK: %[[VAL_10:.*]] = arith.constant 0 : index
+! CHECK: %[[VAL_11:.*]] = fir.shift %[[VAL_10]], %[[VAL_10]] : (index, index) -> !fir.shift<2>
+! CHECK: %[[VAL_12:.*]] = fir.rebox %[[VAL_6]]#0(%[[VAL_11]]) : (!fir.box<!fir.array<10x20x!fir.char<1,?>>>, !fir.shift<2>) -> !fir.box<!fir.array<10x20x!fir.char<1,?>>>
+! CHECK: fir.result %[[VAL_12]] : !fir.box<!fir.array<10x20x!fir.char<1,?>>>
+! CHECK: } else {
+! CHECK: %[[VAL_13:.*]] = fir.absent !fir.box<!fir.array<10x20x!fir.char<1,?>>>
+! CHECK: fir.result %[[VAL_13]] : !fir.box<!fir.array<10x20x!fir.char<1,?>>>
+! CHECK: }
+! CHECK: %[[VAL_14:.*]]:3 = hlfir.associate %[[VAL_8]] {adapt.valuebyref} : (i32) -> (!fir.ref<i32>, !fir.ref<i32>, i1)
+! CHECK: %[[VAL_15:.*]] = fir.if %[[VAL_7]] -> (!fir.box<!fir.array<?x!fir.char<1,?>>>) {
+! CHECK: %[[VAL_16:.*]] = arith.constant 0 : index
+! CHECK: %[[VAL_17:.*]]:2 = hlfir.declare %[[VAL_14]]#1 {uniq_name = "_QMbindc_seq_assocFtakes_optional_charEn"} : (!fir.ref<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
+! CHECK: %[[VAL_18:.*]] = fir.load %[[VAL_17]]#0 : !fir.ref<i32>
+! CHECK: %[[VAL_19:.*]] = fir.convert %[[VAL_18]] : (i32) -> i64
+! CHECK: %[[VAL_20:.*]] = arith.constant 1 : i64
+! CHECK: %[[VAL_21:.*]] = arith.subi %[[VAL_19]], %[[VAL_20]] : i64
+! CHECK: %[[VAL_22:.*]] = arith.constant 1 : i64
+! CHECK: %[[VAL_23:.*]] = arith.addi %[[VAL_21]], %[[VAL_22]] : i64
+! CHECK: %[[VAL_24:.*]] = fir.convert %[[VAL_23]] : (i64) -> index
+! CHECK: %[[VAL_25:.*]] = arith.constant 0 : index
+! CHECK: %[[VAL_26:.*]] = arith.cmpi sgt, %[[VAL_24]], %[[VAL_25]] : index
+! CHECK: %[[VAL_27:.*]] = arith.select %[[VAL_26]], %[[VAL_24]], %[[VAL_25]] : index
+! CHECK: %[[VAL_28:.*]] = fir.shape_shift %[[VAL_16]], %[[VAL_27]] : (index, index) -> !fir.shapeshift<1>
+! CHECK: %[[VAL_29:.*]] = fir.box_elesize %[[VAL_9]] : (!fir.box<!fir.array<10x20x!fir.char<1,?>>>) -> index
+! CHECK: %[[VAL_30:.*]] = fir.box_addr %[[VAL_9]] : (!fir.box<!fir.array<10x20x!fir.char<1,?>>>) -> !fir.ref<!fir.array<10x20x!fir.char<1,?>>>
+! CHECK: %[[VAL_31:.*]] = fir.convert %[[VAL_30]] : (!fir.ref<!fir.array<10x20x!fir.char<1,?>>>) -> !fir.ref<!fir.array<?x!fir.char<1,?>>>
+! CHECK: %[[VAL_32:.*]] = fir.embox %[[VAL_31]](%[[VAL_28]]) typeparams %[[VAL_29]] : (!fir.ref<!fir.array<?x!fir.char<1,?>>>, !fir.shapeshift<1>, index) -> !fir.box<!fir.array<?x!fir.char<1,?>>>
+! CHECK: fir.result %[[VAL_32]] : !fir.box<!fir.array<?x!fir.char<1,?>>>
+! CHECK: } else {
+! CHECK: %[[VAL_33:.*]] = fir.absent !fir.box<!fir.array<?x!fir.char<1,?>>>
+! CHECK: fir.result %[[VAL_33]] : !fir.box<!fir.array<?x!fir.char<1,?>>>
+! CHECK: }
+! CHECK: fir.call @takes_optional_char(%[[VAL_15]], %[[VAL_14]]#1) fastmath<contract> : (!fir.box<!fir.array<?x!fir.char<1,?>>>, !fir.ref<i32>) -> ()
+! CHECK: hlfir.end_associate %[[VAL_14]]#1, %[[VAL_14]]#2 : !fir.ref<i32>, i1
+! CHECK: return
+! CHECK: }
+end module
+
+module poly_seq_assoc
+ interface
+ subroutine takes_poly(x, n)
+ integer :: n
+ class(*) :: x(n)
+ end subroutine
+ subroutine takes_poly_assumed_size(x)
+ class(*) :: x(10, *)
+ end subroutine
+ subroutine takes_optional_poly(x, n)
+ integer :: n
+ class(*), optional :: x(n)
+ end subroutine
+ end interface
+contains
+ subroutine test_poly_1(x)
+ class(*) :: x(10, 20)
+ call takes_poly(x, 100)
+ end subroutine
+! CHECK-LABEL: func.func @_QMpoly_seq_assocPtest_poly_1(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.class<!fir.array<10x20xnone>> {fir.bindc_name = "x"}) {
+! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:.*]] {uniq_name = "_QMpoly_seq_assocFtest_poly_1Ex"} : (!fir.class<!fir.array<10x20xnone>>) -> (!fir.class<!fir.array<10x20xnone>>, !fir.class<!fir.array<10x20xnone>>)
+! CHECK: %[[VAL_2:.*]] = arith.constant 100 : i32
+! CHECK: %[[VAL_3:.*]]:3 = hlfir.associate %[[VAL_2]] {adapt.valuebyref} : (i32) -> (!fir.ref<i32>, !fir.ref<i32>, i1)
+! CHECK: %[[VAL_4:.*]]:2 = hlfir.declare %[[VAL_3]]#1 {uniq_name = "_QMpoly_seq_assocFtakes_polyEn"} : (!fir.ref<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
+! CHECK: %[[VAL_5:.*]] = fir.load %[[VAL_4]]#0 : !fir.ref<i32>
+! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (i32) -> i64
+! CHECK: %[[VAL_7:.*]] = arith.constant 1 : i64
+! CHECK: %[[VAL_8:.*]] = arith.subi %[[VAL_6]], %[[VAL_7]] : i64
+! CHECK: %[[VAL_9:.*]] = arith.constant 1 : i64
+! CHECK: %[[VAL_10:.*]] = arith.addi %[[VAL_8]], %[[VAL_9]] : i64
+! CHECK: %[[VAL_11:.*]] = fir.convert %[[VAL_10]] : (i64) -> index
+! CHECK: %[[VAL_12:.*]] = arith.constant 0 : index
+! CHECK: %[[VAL_13:.*]] = arith.cmpi sgt, %[[VAL_11]], %[[VAL_12]] : index
+! CHECK: %[[VAL_14:.*]] = arith.select %[[VAL_13]], %[[VAL_11]], %[[VAL_12]] : index
+! CHECK: %[[VAL_15:.*]] = fir.shape %[[VAL_14]] : (index) -> !fir.shape<1>
+! CHECK: %[[VAL_16:.*]] = fir.box_addr %[[VAL_1]]#1 : (!fir.class<!fir.array<10x20xnone>>) -> !fir.ref<!fir.array<10x20xnone>>
+! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_16]] : (!fir.ref<!fir.array<10x20xnone>>) -> !fir.ref<!fir.array<?xnone>>
+! CHECK: %[[VAL_18:.*]] = fir.embox %[[VAL_17]](%[[VAL_15]]) source_box %[[VAL_1]]#0 : (!fir.ref<!fir.array<?xnone>>, !fir.shape<1>, !fir.class<!fir.array<10x20xnone>>) -> !fir.class<!fir.array<?xnone>>
+! CHECK: fir.call @_QPtakes_poly(%[[VAL_18]], %[[VAL_3]]#1) fastmath<contract> : (!fir.class<!fir.array<?xnone>>, !fir.ref<i32>) -> ()
+! CHECK: hlfir.end_associate %[[VAL_3]]#1, %[[VAL_3]]#2 : !fir.ref<i32>, i1
+! CHECK: return
+! CHECK: }
+
+ subroutine test_poly_copy_in_copy_out(x)
+ class(*) :: x(:, :)
+ call takes_poly(x, 100)
+ end subroutine
+! CHECK-LABEL: func.func @_QMpoly_seq_assocPtest_poly_copy_in_copy_out(
+! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:.*]] {uniq_name = "_QMpoly_seq_assocFtest_poly_copy_in_copy_outEx"} : (!fir.class<!fir.array<?x?xnone>>) -> (!fir.class<!fir.array<?x?xnone>>, !fir.class<!fir.array<?x?xnone>>)
+! CHECK: %[[VAL_2:.*]] = arith.constant 100 : i32
+! CHECK: %[[VAL_3:.*]]:2 = hlfir.copy_in %[[VAL_1]]#0 : (!fir.class<!fir.array<?x?xnone>>) -> (!fir.class<!fir.array<?x?xnone>>, i1)
+! CHECK: %[[VAL_4:.*]]:3 = hlfir.associate %[[VAL_2]] {adapt.valuebyref} : (i32) -> (!fir.ref<i32>, !fir.ref<i32>, i1)
+! CHECK: %[[VAL_5:.*]]:2 = hlfir.declare %[[VAL_4]]#1 {uniq_name = "_QMpoly_seq_assocFtakes_polyEn"} : (!fir.ref<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
+! CHECK: %[[VAL_6:.*]] = fir.load %[[VAL_5]]#0 : !fir.ref<i32>
+! CHECK: %[[VAL_7:.*]] = fir.convert %[[VAL_6]] : (i32) -> i64
+! CHECK: %[[VAL_8:.*]] = arith.constant 1 : i64
+! CHECK: %[[VAL_9:.*]] = arith.subi %[[VAL_7]], %[[VAL_8]] : i64
+! CHECK: %[[VAL_10:.*]] = arith.constant 1 : i64
+! CHECK: %[[VAL_11:.*]] = arith.addi %[[VAL_9]], %[[VAL_10]] : i64
+! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (i64) -> index
+! CHECK: %[[VAL_13:.*]] = arith.constant 0 : index
+! CHECK: %[[VAL_14:.*]] = arith.cmpi sgt, %[[VAL_12]], %[[VAL_13]] : index
+! CHECK: %[[VAL_15:.*]] = arith.select %[[VAL_14]], %[[VAL_12]], %[[VAL_13]] : index
+! CHECK: %[[VAL_16:.*]] = fir.shape %[[VAL_15]] : (index) -> !fir.shape<1>
+! CHECK: %[[VAL_17:.*]] = fir.box_addr %[[VAL_3]]#0 : (!fir.class<!fir.array<?x?xnone>>) -> !fir.ref<!fir.array<?x?xnone>>
+! CHECK: %[[VAL_18:.*]] = fir.convert %[[VAL_17]] : (!fir.ref<!fir.array<?x?xnone>>) -> !fir.ref<!fir.array<?xnone>>
+! CHECK: %[[VAL_19:.*]] = fir.embox %[[VAL_18]](%[[VAL_16]]) source_box %[[VAL_3]]#0 : (!fir.ref<!fir.array<?xnone>>, !fir.shape<1>, !fir.class<!fir.array<?x?xnone>>) -> !fir.class<!fir.array<?xnone>>
+! CHECK: fir.call @_QPtakes_poly(%[[VAL_19]], %[[VAL_4]]#1) fastmath<contract> : (!fir.class<!fir.array<?xnone>>, !fir.ref<i32>) -> ()
+! CHECK: hlfir.copy_out %[[VAL_3]]#0, %[[VAL_3]]#1 to %[[VAL_1]]#0 : (!fir.class<!fir.array<?x?xnone>>, i1, !fir.class<!fir.array<?x?xnone>>) -> ()
+! CHECK: hlfir.end_associate %[[VAL_4]]#1, %[[VAL_4]]#2 : !fir.ref<i32>, i1
+! CHECK: return
+! CHECK: }
+
+ subroutine test_poly_assumed_size(x)
+ class(*) :: x(:, :)
+ call takes_poly_assumed_size(x)
+ end subroutine
+! CHECK-LABEL: func.func @_QMpoly_seq_assocPtest_poly_assumed_size(
+! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:.*]] {uniq_name = "_QMpoly_seq_assocFtest_poly_assumed_sizeEx"} : (!fir.class<!fir.array<?x?xnone>>) -> (!fir.class<!fir.array<?x?xnone>>, !fir.class<!fir.array<?x?xnone>>)
+! CHECK: %[[VAL_2:.*]]:2 = hlfir.copy_in %[[VAL_1]]#0 : (!fir.class<!fir.array<?x?xnone>>) -> (!fir.class<!fir.array<?x?xnone>>, i1)
+! CHECK: %[[VAL_3:.*]] = arith.constant 10 : i64
+! CHECK: %[[VAL_4:.*]] = arith.constant 1 : i64
+! CHECK: %[[VAL_5:.*]] = arith.subi %[[VAL_3]], %[[VAL_4]] : i64
+! CHECK: %[[VAL_6:.*]] = arith.constant 1 : i64
+! CHECK: %[[VAL_7:.*]] = arith.addi %[[VAL_5]], %[[VAL_6]] : i64
+! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (i64) -> index
+! CHECK: %[[VAL_9:.*]] = arith.constant 0 : index
+! CHECK: %[[VAL_10:.*]] = arith.cmpi sgt, %[[VAL_8]], %[[VAL_9]] : index
+! CHECK: %[[VAL_11:.*]] = arith.select %[[VAL_10]], %[[VAL_8]], %[[VAL_9]] : index
+! CHECK: %[[VAL_12:.*]] = arith.constant -1 : i64
+! CHECK: %[[VAL_13:.*]] = fir.convert %[[VAL_12]] : (i64) -> index
+! CHECK: %[[VAL_14:.*]] = fir.shape %[[VAL_11]], %[[VAL_13]] : (index, index) -> !fir.shape<2>
+! CHECK: %[[VAL_15:.*]] = fir.box_addr %[[VAL_2]]#0 : (!fir.class<!fir.array<?x?xnone>>) -> !fir.ref<!fir.array<?x?xnone>>
+! CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_15]] : (!fir.ref<!fir.array<?x?xnone>>) -> !fir.ref<!fir.array<10x?xnone>>
+! CHECK: %[[VAL_17:.*]] = fir.embox %[[VAL_16]](%[[VAL_14]]) source_box %[[VAL_2]]#0 : (!fir.ref<!fir.array<10x?xnone>>, !fir.shape<2>, !fir.class<!fir.array<?x?xnone>>) -> !fir.class<!fir.array<10x?xnone>>
+! CHECK: fir.call @_QPtakes_poly_assumed_size(%[[VAL_17]]) fastmath<contract> : (!fir.class<!fir.array<10x?xnone>>) -> ()
+! CHECK: hlfir.copy_out %[[VAL_2]]#0, %[[VAL_2]]#1 to %[[VAL_1]]#0 : (!fir.class<!fir.array<?x?xnone>>, i1, !fir.class<!fir.array<?x?xnone>>) -> ()
+! CHECK: return
+! CHECK: }
+
+ subroutine test_optional_poly(x)
+ class(*), optional :: x(10, 20)
+ call takes_optional_poly(x, 100)
+ end subroutine
+! CHECK-LABEL: func.func @_QMpoly_seq_assocPtest_optional_poly(
+! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0:.*]] {fortran_attrs = #fir.var_attrs<optional>, uniq_name = "_QMpoly_seq_assocFtest_optional_polyEx"} : (!fir.class<!fir.array<10x20xnone>>) -> (!fir.class<!fir.array<10x20xnone>>, !fir.class<!fir.array<10x20xnone>>)
+! CHECK: %[[VAL_2:.*]] = fir.is_present %[[VAL_1]]#0 : (!fir.class<!fir.array<10x20xnone>>) -> i1
+! CHECK: %[[VAL_3:.*]] = arith.constant 100 : i32
+! CHECK: %[[VAL_4:.*]] = fir.if %[[VAL_2]] -> (!fir.class<!fir.array<10x20xnone>>) {
+! CHECK: fir.result %[[VAL_1]]#0 : !fir.class<!fir.array<10x20xnone>>
+! CHECK: } else {
+! CHECK: %[[VAL_5:.*]] = fir.absent !fir.class<!fir.array<10x20xnone>>
+! CHECK: fir.result %[[VAL_5]] : !fir.class<!fir.array<10x20xnone>>
+! CHECK: }
+! CHECK: %[[VAL_6:.*]]:3 = hlfir.associate %[[VAL_3]] {adapt.valuebyref} : (i32) -> (!fir.ref<i32>, !fir.ref<i32>, i1)
+! CHECK: %[[VAL_7:.*]] = fir.if %[[VAL_2]] -> (!fir.class<!fir.array<?xnone>>) {
+! CHECK: %[[VAL_8:.*]]:2 = hlfir.declare %[[VAL_6]]#1 {uniq_name = "_QMpoly_seq_assocFtakes_optional_polyEn"} : (!fir.ref<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
+! CHECK: %[[VAL_9:.*]] = fir.load %[[VAL_8]]#0 : !fir.ref<i32>
+! CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_9]] : (i32) -> i64
+! CHECK: %[[VAL_11:.*]] = arith.constant 1 : i64
+! CHECK: %[[VAL_12:.*]] = arith.subi %[[VAL_10]], %[[VAL_11]] : i64
+! CHECK: %[[VAL_13:.*]] = arith.constant 1 : i64
+! CHECK: %[[VAL_14:.*]] = arith.addi %[[VAL_12]], %[[VAL_13]] : i64
+! CHECK: %[[VAL_15:.*]] = fir.convert %[[VAL_14]] : (i64) -> index
+! CHECK: %[[VAL_16:.*]] = arith.constant 0 : index
+! CHECK: %[[VAL_17:.*]] = arith.cmpi sgt, %[[VAL_15]], %[[VAL_16]] : index
+! CHECK: %[[VAL_18:.*]] = arith.select %[[VAL_17]], %[[VAL_15]], %[[VAL_16]] : index
+! CHECK: %[[VAL_19:.*]] = fir.shape %[[VAL_18]] : (index) -> !fir.shape<1>
+! CHECK: %[[VAL_20:.*]] = fir.box_addr %[[VAL_4]] : (!fir.class<!fir.array<10x20xnone>>) -> !fir.ref<!fir.array<10x20xnone>>
+! CHECK: %[[VAL_21:.*]] = fir.convert %[[VAL_20]] : (!fir.ref<!fir.array<10x20xnone>>) -> !fir.ref<!fir.array<?xnone>>
+! CHECK: %[[VAL_22:.*]] = fir.embox %[[VAL_21]](%[[VAL_19]]) source_box %[[VAL_4]] : (!fir.ref<!fir.array<?xnone>>, !fir.shape<1>, !fir.class<!fir.array<10x20xnone>>) -> !fir.class<!fir.array<?xnone>>
+! CHECK: fir.result %[[VAL_22]] : !fir.class<!fir.array<?xnone>>
+! CHECK: } else {
+! CHECK: %[[VAL_23:.*]] = fir.absent !fir.class<!fir.array<?xnone>>
+! CHECK: fir.result %[[VAL_23]] : !fir.class<!fir.array<?xnone>>
+! CHECK: }
+! CHECK: fir.call @_QPtakes_optional_poly(%[[VAL_7]], %[[VAL_6]]#1) fastmath<contract> : (!fir.class<!fir.array<?xnone>>, !fir.ref<i32>) -> ()
+! CHECK: hlfir.end_associate %[[VAL_6]]#1, %[[VAL_6]]#2 : !fir.ref<i32>, i1
+! CHECK: return
+! CHECK: }
+end module
More information about the flang-commits
mailing list