[flang-commits] [flang] a49f630 - [flang] Lower passing non assumed-rank/size to assumed-ranks (#79145)
via flang-commits
flang-commits at lists.llvm.org
Fri Jan 26 07:01:56 PST 2024
Author: jeanPerier
Date: 2024-01-26T16:01:51+01:00
New Revision: a49f630cf6f12f3ca2d5814a581986140ee6e474
URL: https://github.com/llvm/llvm-project/commit/a49f630cf6f12f3ca2d5814a581986140ee6e474
DIFF: https://github.com/llvm/llvm-project/commit/a49f630cf6f12f3ca2d5814a581986140ee6e474.diff
LOG: [flang] Lower passing non assumed-rank/size to assumed-ranks (#79145)
Start implementing assumed-rank support as described in
https://github.com/llvm/llvm-project/blob/main/flang/docs/AssumedRank.md
This commit holds the minimal support for lowering calls to procedure
with assumed-rank arguments where the procedure implementation is done
in C.
The case for passing assumed-size to assumed-rank is left TODO since it
will be done a change in assumed-size lowering that is better done in
another patch.
Care is taken to set the lower bounds to zero when passing non allocatable no pointer as descriptor
to a BIND(C) procedure as required per 18.5.3 point 3. This was not done before while the requirements also applies to non assumed-rank descriptors. This change required special attention with IGNORE_TKR(t) to avoid emitting invalid fir.rebox operations (the actual argument type must be used in this case as the output type).
Implementation of Fortran procedure with assumed-rank arguments is still
TODO.
Added:
flang/test/Lower/HLFIR/assumed-rank-iface-alloc-ptr.f90
flang/test/Lower/HLFIR/assumed-rank-iface.f90
flang/test/Lower/HLFIR/ignore-type-assumed-shape.f90
Modified:
flang/include/flang/Optimizer/Builder/FIRBuilder.h
flang/include/flang/Optimizer/Builder/HLFIRTools.h
flang/include/flang/Optimizer/Dialect/FIRType.h
flang/lib/Lower/CallInterface.cpp
flang/lib/Lower/ConvertCall.cpp
flang/lib/Lower/ConvertExprToHLFIR.cpp
flang/lib/Lower/ConvertVariable.cpp
flang/lib/Optimizer/Builder/FIRBuilder.cpp
flang/lib/Optimizer/Dialect/FIRType.cpp
flang/test/Lower/HLFIR/ignore-rank-unlimited-polymorphic.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Optimizer/Builder/FIRBuilder.h b/flang/include/flang/Optimizer/Builder/FIRBuilder.h
index 30f20ccfa1543f7..5384f6e8121ec6b 100644
--- a/flang/include/flang/Optimizer/Builder/FIRBuilder.h
+++ b/flang/include/flang/Optimizer/Builder/FIRBuilder.h
@@ -109,7 +109,8 @@ class FirOpBuilder : public mlir::OpBuilder, public mlir::OpBuilder::Listener {
/// after type conversion and the imaginary part is zero.
mlir::Value convertWithSemantics(mlir::Location loc, mlir::Type toTy,
mlir::Value val,
- bool allowCharacterConversion = false);
+ bool allowCharacterConversion = false,
+ bool allowRebox = false);
/// Get the entry block of the current Function
mlir::Block *getEntryBlock() { return &getFunction().front(); }
diff --git a/flang/include/flang/Optimizer/Builder/HLFIRTools.h b/flang/include/flang/Optimizer/Builder/HLFIRTools.h
index 46dc79f41a18b4b..efbd57c77de5d5c 100644
--- a/flang/include/flang/Optimizer/Builder/HLFIRTools.h
+++ b/flang/include/flang/Optimizer/Builder/HLFIRTools.h
@@ -71,6 +71,9 @@ class Entity : public mlir::Value {
/// Is this an array or an assumed ranked entity?
bool isArray() const { return getRank() != 0; }
+ /// Is this an assumed ranked entity?
+ bool isAssumedRank() const { return getRank() == -1; }
+
/// Return the rank of this entity or -1 if it is an assumed rank.
int getRank() const {
mlir::Type type = fir::unwrapPassByRefType(fir::unwrapRefType(getType()));
diff --git a/flang/include/flang/Optimizer/Dialect/FIRType.h b/flang/include/flang/Optimizer/Dialect/FIRType.h
index 8672fcaf60f705f..75106b3028ac903 100644
--- a/flang/include/flang/Optimizer/Dialect/FIRType.h
+++ b/flang/include/flang/Optimizer/Dialect/FIRType.h
@@ -46,6 +46,13 @@ class BaseBoxType : public mlir::Type {
/// Unwrap element type from fir.heap, fir.ptr and fir.array.
mlir::Type unwrapInnerType() const;
+ /// Is this the box for an assumed rank?
+ bool isAssumedRank() const;
+
+ /// Return the same type, except for the shape, that is taken the shape
+ /// of shapeMold.
+ BaseBoxType getBoxTypeWithNewShape(mlir::Type shapeMold) const;
+
/// Methods for support type inquiry through isa, cast, and dyn_cast.
static bool classof(mlir::Type type);
};
@@ -428,6 +435,13 @@ inline mlir::Type updateTypeForUnlimitedPolymorphic(mlir::Type ty) {
return ty;
}
+/// Replace the element type of \p type by \p newElementType, preserving
+/// all other layers of the type (fir.ref/ptr/heap/array/box/class).
+/// If \p turnBoxIntoClass and the input is a fir.box, it will be turned into
+/// a fir.class in the result.
+mlir::Type changeElementType(mlir::Type type, mlir::Type newElementType,
+ bool turnBoxIntoClass);
+
/// Is `t` an address to fir.box or class type?
inline bool isBoxAddress(mlir::Type t) {
return fir::isa_ref_type(t) && fir::unwrapRefType(t).isa<fir::BaseBoxType>();
diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp
index 45487197fcbbbe7..06150da6f239991 100644
--- a/flang/lib/Lower/CallInterface.cpp
+++ b/flang/lib/Lower/CallInterface.cpp
@@ -867,9 +867,8 @@ class Fortran::lower::CallInterfaceImpl {
getRefType(Fortran::evaluate::DynamicType dynamicType,
const Fortran::evaluate::characteristics::DummyDataObject &obj) {
mlir::Type type = translateDynamicType(dynamicType);
- fir::SequenceType::Shape bounds = getBounds(obj.type.shape());
- if (!bounds.empty())
- type = fir::SequenceType::get(bounds, type);
+ if (std::optional<fir::SequenceType::Shape> bounds = getBounds(obj.type))
+ type = fir::SequenceType::get(*bounds, type);
return fir::ReferenceType::get(type);
}
@@ -993,8 +992,6 @@ class Fortran::lower::CallInterfaceImpl {
using ShapeAttr = Fortran::evaluate::characteristics::TypeAndShape::Attr;
const Fortran::evaluate::characteristics::TypeAndShape::Attrs &shapeAttrs =
obj.type.attrs();
- if (shapeAttrs.test(ShapeAttr::AssumedRank))
- TODO(loc, "assumed rank in procedure interface");
if (shapeAttrs.test(ShapeAttr::Coarray))
TODO(loc, "coarray: dummy argument coarray in procedure interface");
@@ -1003,9 +1000,8 @@ class Fortran::lower::CallInterfaceImpl {
Fortran::evaluate::DynamicType dynamicType = obj.type.type();
mlir::Type type = translateDynamicType(dynamicType);
- fir::SequenceType::Shape bounds = getBounds(obj.type.shape());
- if (!bounds.empty())
- type = fir::SequenceType::get(bounds, type);
+ if (std::optional<fir::SequenceType::Shape> bounds = getBounds(obj.type))
+ type = fir::SequenceType::get(*bounds, type);
if (obj.attrs.test(Attrs::Allocatable))
type = fir::HeapType::get(type);
if (obj.attrs.test(Attrs::Pointer))
@@ -1123,14 +1119,14 @@ class Fortran::lower::CallInterfaceImpl {
result.GetTypeAndShape();
assert(typeAndShape && "expect type for non proc pointer result");
mlirType = translateDynamicType(typeAndShape->type());
- fir::SequenceType::Shape bounds = getBounds(typeAndShape->shape());
const auto *resTypeAndShape{result.GetTypeAndShape()};
bool resIsPolymorphic =
resTypeAndShape && resTypeAndShape->type().IsPolymorphic();
bool resIsAssumedType =
resTypeAndShape && resTypeAndShape->type().IsAssumedType();
- if (!bounds.empty())
- mlirType = fir::SequenceType::get(bounds, mlirType);
+ if (std::optional<fir::SequenceType::Shape> bounds =
+ getBounds(*typeAndShape))
+ mlirType = fir::SequenceType::get(*bounds, mlirType);
if (result.attrs.test(Attr::Allocatable))
mlirType = fir::wrapInClassOrBoxType(
fir::HeapType::get(mlirType), resIsPolymorphic, resIsAssumedType);
@@ -1157,9 +1153,17 @@ class Fortran::lower::CallInterfaceImpl {
setSaveResult();
}
- fir::SequenceType::Shape getBounds(const Fortran::evaluate::Shape &shape) {
+ // Return nullopt for scalars, empty vector for assumed rank, and a vector
+ // with the shape (may contain unknown extents) for arrays.
+ std::optional<fir::SequenceType::Shape> getBounds(
+ const Fortran::evaluate::characteristics::TypeAndShape &typeAndShape) {
+ using ShapeAttr = Fortran::evaluate::characteristics::TypeAndShape::Attr;
+ if (typeAndShape.shape().empty() &&
+ !typeAndShape.attrs().test(ShapeAttr::AssumedRank))
+ return std::nullopt;
fir::SequenceType::Shape bounds;
- for (const std::optional<Fortran::evaluate::ExtentExpr> &extent : shape) {
+ for (const std::optional<Fortran::evaluate::ExtentExpr> &extent :
+ typeAndShape.shape()) {
fir::SequenceType::Extent bound = fir::SequenceType::getUnknownExtent();
if (std::optional<std::int64_t> i = toInt64(extent))
bound = *i;
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index 57ac9d0652b3176..01e08402c0539c8 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -373,8 +373,14 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
// TODO: remove this TODO once the old lowering is gone.
TODO(loc, "derived type argument passed by value");
} else {
+ // With the lowering to HLFIR, box arguments have already been built
+ // according to the attributes, rank, bounds, and type they should have.
+ // Do not attempt any reboxing here that could break this.
+ bool legacyLowering =
+ !converter.getLoweringOptions().getLowerToHighLevelFIR();
cast = builder.convertWithSemantics(loc, snd, fst,
- callingImplicitInterface);
+ callingImplicitInterface,
+ /*allowRebox=*/legacyLowering);
}
}
operands.push_back(cast);
@@ -650,6 +656,13 @@ struct CallContext {
return false;
}
+ /// Is this a call to a BIND(C) procedure?
+ bool isBindcCall() const {
+ if (const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol())
+ return Fortran::semantics::IsBindCProcedure(*symbol);
+ return false;
+ }
+
const Fortran::evaluate::ProcedureRef &procRef;
Fortran::lower::AbstractConverter &converter;
Fortran::lower::SymMap &symMap;
@@ -859,6 +872,22 @@ static hlfir::Entity fixProcedureDummyMismatch(mlir::Location loc,
return hlfir::Entity{boxProc};
}
+mlir::Value static getZeroLowerBounds(mlir::Location loc,
+ fir::FirOpBuilder &builder,
+ hlfir::Entity entity) {
+ // Assumed rank should not fall here, but better safe than sorry until
+ // implemented.
+ if (entity.isAssumedRank())
+ TODO(loc, "setting lower bounds of assumed rank to zero before passing it "
+ "to BIND(C) procedure");
+ if (entity.getRank() < 1)
+ return {};
+ mlir::Value zero =
+ builder.createIntegerConstant(loc, builder.getIndexType(), 0);
+ llvm::SmallVector<mlir::Value> lowerBounds(entity.getRank(), zero);
+ return builder.genShift(loc, lowerBounds);
+}
+
/// When dummy is not ALLOCATABLE, POINTER and is not passed in register,
/// prepare the actual argument according to the interface. Do as needed:
/// - address element if this is an array argument in an elemental call.
@@ -874,11 +903,10 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
const Fortran::lower::PreparedActualArgument &preparedActual,
mlir::Type dummyType,
const Fortran::lower::CallerInterface::PassedEntity &arg,
- const Fortran::lower::SomeExpr &expr,
- Fortran::lower::AbstractConverter &converter) {
+ const Fortran::lower::SomeExpr &expr, CallContext &callContext) {
Fortran::evaluate::FoldingContext &foldingContext =
- converter.getFoldingContext();
+ callContext.converter.getFoldingContext();
// Step 1: get the actual argument, which includes addressing the
// element if this is an array in an elemental call.
@@ -922,8 +950,10 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
return PreparedDummyArgument{actual, /*cleanups=*/{}};
}
+ const bool ignoreTKRtype = arg.testTKR(Fortran::common::IgnoreTKR::Type);
const bool passingPolymorphicToNonPolymorphic =
- actual.isPolymorphic() && !fir::isPolymorphicType(dummyType);
+ actual.isPolymorphic() && !fir::isPolymorphicType(dummyType) &&
+ !ignoreTKRtype;
// When passing a CLASS(T) to TYPE(T), only the "T" part must be
// passed. Unless the entity is a scalar passed by raw address, a
@@ -942,6 +972,25 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
(passingPolymorphicToNonPolymorphic ||
!Fortran::evaluate::IsSimplyContiguous(expr, foldingContext));
+ const bool actualIsAssumedRank = actual.isAssumedRank();
+ // 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.
+ mlir::Type dummyTypeWithActualRank = dummyType;
+ if (auto baseBoxDummy = mlir::dyn_cast<fir::BaseBoxType>(dummyType))
+ if (baseBoxDummy.isAssumedRank() ||
+ arg.testTKR(Fortran::common::IgnoreTKR::Rank))
+ dummyTypeWithActualRank =
+ baseBoxDummy.getBoxTypeWithNewShape(actual.getType());
+ // Preserve the actual type in the argument preparation in case IgnoreTKR(t)
+ // is set (descriptors must be created with the actual type in this case, and
+ // copy-in/copy-out should be driven by the contiguity with regard to the
+ // actual type).
+ if (ignoreTKRtype)
+ dummyTypeWithActualRank = fir::changeElementType(
+ dummyTypeWithActualRank, actual.getFortranElementType(),
+ actual.isPolymorphic());
+
// Step 2: prepare the storage for the dummy arguments, ensuring that it
// matches the dummy requirements (e.g., must be contiguous or must be
// a temporary).
@@ -952,8 +1001,11 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
if (mustSetDynamicTypeToDummyType) {
// Note: this is important to do this before any copy-in or copy so
// that the dummy is contiguous according to the dummy type.
- mlir::Type boxType =
- fir::BoxType::get(hlfir::getFortranElementOrSequenceType(dummyType));
+ if (actualIsAssumedRank)
+ TODO(loc, "passing polymorphic assumed-rank to non polymorphic dummy "
+ "argument");
+ mlir::Type boxType = fir::BoxType::get(
+ hlfir::getFortranElementOrSequenceType(dummyTypeWithActualRank));
entity = hlfir::Entity{builder.create<fir::ReboxOp>(
loc, boxType, entity, /*shape=*/mlir::Value{},
/*slice=*/mlir::Value{})};
@@ -978,6 +1030,8 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
// Copy-in non contiguous variables.
assert(entity.getType().isa<fir::BaseBoxType>() &&
"expect non simply contiguous variables to be boxes");
+ if (actualIsAssumedRank)
+ TODO(loc, "copy-in and copy-out of assumed-rank arguments");
// 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.
@@ -996,7 +1050,7 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
} else {
// The actual is an expression value, place it into a temporary
// and register the temporary destruction after the call.
- mlir::Type storageType = converter.genType(expr);
+ mlir::Type storageType = callContext.converter.genType(expr);
mlir::NamedAttribute byRefAttr = fir::getAdaptToByRefAttr(builder);
hlfir::AssociateOp associate = hlfir::genAssociateExpr(
loc, builder, entity, storageType, "", byRefAttr);
@@ -1010,8 +1064,9 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
// TODO: this can probably be optimized by associating the expression
// with properly typed temporary, but this needs either a new operation
// or making the hlfir.associate more complex.
- mlir::Type boxType =
- fir::BoxType::get(hlfir::getFortranElementOrSequenceType(dummyType));
+ assert(!actualIsAssumedRank && "only variables are assumed-rank");
+ mlir::Type boxType = fir::BoxType::get(
+ hlfir::getFortranElementOrSequenceType(dummyTypeWithActualRank));
entity = hlfir::Entity{builder.create<fir::ReboxOp>(
loc, boxType, entity, /*shape=*/mlir::Value{},
/*slice=*/mlir::Value{})};
@@ -1029,9 +1084,9 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
// Step 3: now that the dummy argument storage has been prepared, package
// it according to the interface.
mlir::Value addr;
- if (dummyType.isa<fir::BoxCharType>()) {
+ if (dummyTypeWithActualRank.isa<fir::BoxCharType>()) {
addr = hlfir::genVariableBoxChar(loc, builder, entity);
- } else if (dummyType.isa<fir::BaseBoxType>()) {
+ } else if (dummyTypeWithActualRank.isa<fir::BaseBoxType>()) {
entity = hlfir::genVariableBox(loc, builder, entity);
// Ensures the box has the right attributes and that it holds an
// addendum if needed.
@@ -1043,39 +1098,55 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
// has the dummy attributes in BIND(C) contexts.
const bool actualBoxHasAllocatableOrPointerFlag =
fir::isa_ref_type(boxEleType);
+ // Fortran 2018 18.5.3, pp3: BIND(C) non pointer allocatable descriptors
+ // must have zero lower bounds.
+ bool needsZeroLowerBounds = callContext.isBindcCall() && entity.isArray();
// On the callee side, the current code generated for unlimited
// polymorphic might unconditionally read the addendum. Intrinsic type
// descriptors may not have an addendum, the rebox below will create a
// descriptor with an addendum in such case.
const bool actualBoxHasAddendum = fir::boxHasAddendum(actualBoxType);
const bool needToAddAddendum =
- fir::isUnlimitedPolymorphicType(dummyType) && !actualBoxHasAddendum;
- mlir::Type reboxType = dummyType;
- if (needToAddAddendum || actualBoxHasAllocatableOrPointerFlag) {
- if (fir::getBoxRank(dummyType) != fir::getBoxRank(actualBoxType)) {
- // This may happen only with IGNORE_TKR(R).
- if (!arg.testTKR(Fortran::common::IgnoreTKR::Rank))
- DIE("actual and dummy arguments must have equal ranks");
- // Only allow it for unlimited polymorphic dummy arguments
- // for now.
- if (!fir::isUnlimitedPolymorphicType(dummyType))
- TODO(loc, "actual/dummy rank mismatch for not unlimited polymorphic "
- "dummy.");
- auto elementType = fir::updateTypeForUnlimitedPolymorphic(boxEleType);
- if (fir::isAssumedType(dummyType))
- reboxType = fir::BoxType::get(elementType);
+ fir::isUnlimitedPolymorphicType(dummyTypeWithActualRank) &&
+ !actualBoxHasAddendum;
+ if (needToAddAddendum || actualBoxHasAllocatableOrPointerFlag ||
+ needsZeroLowerBounds) {
+ if (actualIsAssumedRank) {
+ if (needToAddAddendum)
+ TODO(loc, "passing intrinsic assumed-rank to unlimited polymorphic "
+ "assumed-rank");
else
- reboxType = fir::ClassType::get(elementType);
+ TODO(loc, "passing pointer or allocatable assumed-rank to non "
+ "pointer non allocatable assumed-rank");
}
+ mlir::Value shift{};
+ if (needsZeroLowerBounds)
+ shift = getZeroLowerBounds(loc, builder, entity);
entity = hlfir::Entity{builder.create<fir::ReboxOp>(
- loc, reboxType, entity, /*shape=*/mlir::Value{},
+ loc, dummyTypeWithActualRank, entity, /*shape=*/shift,
/*slice=*/mlir::Value{})};
}
addr = entity;
} else {
addr = hlfir::genVariableRawAddress(loc, builder, entity);
}
- preparedDummy.dummy = builder.createConvert(loc, dummyType, addr);
+ // The last extent created for assumed-rank descriptors must be -1 (18.5.3
+ // point 5.). This should be done when creating the assumed-size shape for
+ // consistency.
+ if (auto baseBoxDummy = mlir::dyn_cast<fir::BaseBoxType>(dummyType))
+ if (baseBoxDummy.isAssumedRank())
+ if (const Fortran::semantics::Symbol *sym =
+ Fortran::evaluate::UnwrapWholeSymbolDataRef(expr))
+ if (Fortran::semantics::IsAssumedSizeArray(sym->GetUltimate()))
+ TODO(loc, "passing assumed-size to assumed-rank array");
+
+ // For ranked actual passed to assumed-rank dummy, the cast to assumed-rank
+ // box is inserted when building the fir.call op. Inserting it here would
+ // cause the fir.if results to be assumed-rank in case of OPTIONAL dummy,
+ // causing extra runtime costs due to the unknown runtime size of assumed-rank
+ // descriptors.
+ preparedDummy.dummy =
+ builder.createConvert(loc, dummyTypeWithActualRank, addr);
return preparedDummy;
}
@@ -1087,11 +1158,10 @@ static PreparedDummyArgument prepareUserCallActualArgument(
const Fortran::lower::PreparedActualArgument &preparedActual,
mlir::Type dummyType,
const Fortran::lower::CallerInterface::PassedEntity &arg,
- const Fortran::lower::SomeExpr &expr,
- Fortran::lower::AbstractConverter &converter) {
+ const Fortran::lower::SomeExpr &expr, CallContext &callContext) {
if (!preparedActual.handleDynamicOptional())
return preparePresentUserCallActualArgument(
- loc, builder, preparedActual, dummyType, arg, expr, converter);
+ loc, builder, preparedActual, dummyType, arg, expr, callContext);
// Conditional dummy argument preparation. The actual may be absent
// at runtime, causing any addressing, copy, and packaging to have
@@ -1113,7 +1183,7 @@ static PreparedDummyArgument prepareUserCallActualArgument(
builder.setInsertionPointToStart(preparationBlock);
PreparedDummyArgument unconditionalDummy =
preparePresentUserCallActualArgument(loc, builder, preparedActual,
- dummyType, arg, expr, converter);
+ dummyType, arg, expr, callContext);
builder.restoreInsertionPoint(insertPt);
// TODO: when forwarding an optional to an optional of the same kind
@@ -1216,9 +1286,8 @@ genUserCall(Fortran::lower::PreparedActualArguments &loweredActuals,
case PassBy::BaseAddress:
case PassBy::BoxProcRef:
case PassBy::BoxChar: {
- PreparedDummyArgument preparedDummy =
- prepareUserCallActualArgument(loc, builder, *preparedActual, argTy,
- arg, *expr, callContext.converter);
+ PreparedDummyArgument preparedDummy = prepareUserCallActualArgument(
+ loc, builder, *preparedActual, argTy, arg, *expr, callContext);
callCleanUps.append(preparedDummy.cleanups.rbegin(),
preparedDummy.cleanups.rend());
caller.placeInput(arg, preparedDummy.dummy);
@@ -1261,10 +1330,20 @@ genUserCall(Fortran::lower::PreparedActualArguments &loweredActuals,
// Passing a non POINTER actual argument to a POINTER dummy argument.
// Create a pointer of the dummy argument type and assign the actual
// argument to it.
- mlir::Type dataTy = fir::unwrapRefType(argTy);
+ auto dataTy = llvm::cast<fir::BaseBoxType>(fir::unwrapRefType(argTy));
fir::ExtendedValue actualExv = Fortran::lower::convertToAddress(
loc, callContext.converter, actual, callContext.stmtCtx,
hlfir::getFortranElementType(dataTy));
+ // If the dummy is an assumed-rank pointer, allocate a pointer
+ // descriptor with the actual argument rank (if it is not assumed-rank
+ // itself).
+ if (dataTy.isAssumedRank()) {
+ dataTy =
+ dataTy.getBoxTypeWithNewShape(fir::getBase(actualExv).getType());
+ if (dataTy.isAssumedRank())
+ TODO(loc, "associating assumed-rank target to pointer assumed-rank "
+ "argument");
+ }
mlir::Value irBox = builder.createTemporary(loc, dataTy);
fir::MutableBoxValue ptrBox(irBox,
/*nonDeferredParams=*/mlir::ValueRange{},
@@ -1277,8 +1356,7 @@ genUserCall(Fortran::lower::PreparedActualArguments &loweredActuals,
// Passing a POINTER to a POINTER, or an ALLOCATABLE to an ALLOCATABLE.
assert(actual.isMutableBox() && "actual must be a mutable box");
if (fir::isAllocatableType(argTy) && arg.isIntentOut() &&
- Fortran::semantics::IsBindCProcedure(
- *callContext.procRef.proc().GetSymbol())) {
+ callContext.isBindcCall()) {
// INTENT(OUT) allocatables are deallocated on the callee side,
// but BIND(C) procedures may be implemented in C, so deallocation is
// also done on the caller side (if the procedure is implemented in
@@ -2186,8 +2264,7 @@ genProcedureRef(CallContext &callContext) {
// intrinsic unless it is bind(c) (since implementation is external from
// module).
if (Fortran::lower::isIntrinsicModuleProcRef(callContext.procRef) &&
- !Fortran::semantics::IsBindCProcedure(
- *callContext.procRef.proc().GetSymbol()))
+ !callContext.isBindcCall())
return genIntrinsicRef(nullptr, callContext);
if (callContext.isStatementFunctionCall())
diff --git a/flang/lib/Lower/ConvertExprToHLFIR.cpp b/flang/lib/Lower/ConvertExprToHLFIR.cpp
index e4e84b1d883fca8..01e58144fa4b580 100644
--- a/flang/lib/Lower/ConvertExprToHLFIR.cpp
+++ b/flang/lib/Lower/ConvertExprToHLFIR.cpp
@@ -405,8 +405,8 @@ class HlfirDesignatorBuilder {
.Case<fir::SequenceType>([&](fir::SequenceType seqTy) -> mlir::Type {
return fir::SequenceType::get(seqTy.getShape(), newEleTy);
})
- .Case<fir::PointerType, fir::HeapType, fir::ReferenceType,
- fir::BoxType>([&](auto t) -> mlir::Type {
+ .Case<fir::PointerType, fir::HeapType, fir::ReferenceType, fir::BoxType,
+ fir::ClassType>([&](auto t) -> mlir::Type {
using FIRT = decltype(t);
return FIRT::get(changeElementType(t.getEleTy(), newEleTy));
})
diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp
index 006cc1417b63d11..afa71e911046932 100644
--- a/flang/lib/Lower/ConvertVariable.cpp
+++ b/flang/lib/Lower/ConvertVariable.cpp
@@ -1834,6 +1834,9 @@ void Fortran::lower::mapSymbolAttributes(
return;
}
+ if (Fortran::evaluate::IsAssumedRank(sym))
+ TODO(loc, "assumed-rank variable in procedure implemented in Fortran");
+
Fortran::lower::BoxAnalyzer ba;
ba.analyze(sym);
diff --git a/flang/lib/Optimizer/Builder/FIRBuilder.cpp b/flang/lib/Optimizer/Builder/FIRBuilder.cpp
index df42dc8a3d0c8ba..141f8fcd3ab5fcd 100644
--- a/flang/lib/Optimizer/Builder/FIRBuilder.cpp
+++ b/flang/lib/Optimizer/Builder/FIRBuilder.cpp
@@ -308,10 +308,9 @@ fir::GlobalOp fir::FirOpBuilder::createGlobal(
return glob;
}
-mlir::Value
-fir::FirOpBuilder::convertWithSemantics(mlir::Location loc, mlir::Type toTy,
- mlir::Value val,
- bool allowCharacterConversion) {
+mlir::Value fir::FirOpBuilder::convertWithSemantics(
+ mlir::Location loc, mlir::Type toTy, mlir::Value val,
+ bool allowCharacterConversion, bool allowRebox) {
assert(toTy && "store location must be typed");
auto fromTy = val.getType();
if (fromTy == toTy)
@@ -369,13 +368,15 @@ fir::FirOpBuilder::convertWithSemantics(mlir::Location loc, mlir::Type toTy,
return create<fir::EmboxProcOp>(loc, toTy, proc);
}
- if (((fir::isPolymorphicType(fromTy) &&
- (fir::isAllocatableType(fromTy) || fir::isPointerType(fromTy)) &&
- fir::isPolymorphicType(toTy)) ||
- (fir::isPolymorphicType(fromTy) && toTy.isa<fir::BoxType>())) &&
- !(fir::isUnlimitedPolymorphicType(fromTy) && fir::isAssumedType(toTy)))
- return create<fir::ReboxOp>(loc, toTy, val, mlir::Value{},
- /*slice=*/mlir::Value{});
+ // Legacy: remove when removing non HLFIR lowering path.
+ if (allowRebox)
+ if (((fir::isPolymorphicType(fromTy) &&
+ (fir::isAllocatableType(fromTy) || fir::isPointerType(fromTy)) &&
+ fir::isPolymorphicType(toTy)) ||
+ (fir::isPolymorphicType(fromTy) && toTy.isa<fir::BoxType>())) &&
+ !(fir::isUnlimitedPolymorphicType(fromTy) && fir::isAssumedType(toTy)))
+ return create<fir::ReboxOp>(loc, toTy, val, mlir::Value{},
+ /*slice=*/mlir::Value{});
return createConvert(loc, toTy, val);
}
diff --git a/flang/lib/Optimizer/Dialect/FIRType.cpp b/flang/lib/Optimizer/Dialect/FIRType.cpp
index 110b3a5e0620e20..0e80110848fa805 100644
--- a/flang/lib/Optimizer/Dialect/FIRType.cpp
+++ b/flang/lib/Optimizer/Dialect/FIRType.cpp
@@ -588,6 +588,33 @@ std::string getTypeAsString(mlir::Type ty, const fir::KindMapping &kindMap,
return name.str();
}
+mlir::Type changeElementType(mlir::Type type, mlir::Type newElementType,
+ bool turnBoxIntoClass) {
+ return llvm::TypeSwitch<mlir::Type, mlir::Type>(type)
+ .Case<fir::SequenceType>([&](fir::SequenceType seqTy) -> mlir::Type {
+ return fir::SequenceType::get(seqTy.getShape(), newElementType);
+ })
+ .Case<fir::PointerType, fir::HeapType, fir::ReferenceType,
+ fir::ClassType>([&](auto t) -> mlir::Type {
+ using FIRT = decltype(t);
+ return FIRT::get(
+ changeElementType(t.getEleTy(), newElementType, turnBoxIntoClass));
+ })
+ .Case<fir::BoxType>([&](fir::BoxType t) -> mlir::Type {
+ mlir::Type newInnerType =
+ changeElementType(t.getEleTy(), newElementType, false);
+ if (turnBoxIntoClass)
+ return fir::ClassType::get(newInnerType);
+ return fir::BoxType::get(newInnerType);
+ })
+ .Default([&](mlir::Type t) -> mlir::Type {
+ assert((fir::isa_trivial(t) || llvm::isa<fir::RecordType>(t) ||
+ llvm::isa<mlir::NoneType>(t)) &&
+ "unexpected FIR leaf type");
+ return newElementType;
+ });
+}
+
} // namespace fir
namespace {
@@ -1242,6 +1269,46 @@ mlir::Type BaseBoxType::unwrapInnerType() const {
return fir::unwrapInnerType(getEleTy());
}
+static mlir::Type
+changeTypeShape(mlir::Type type,
+ std::optional<fir::SequenceType::ShapeRef> newShape) {
+ return llvm::TypeSwitch<mlir::Type, mlir::Type>(type)
+ .Case<fir::SequenceType>([&](fir::SequenceType seqTy) -> mlir::Type {
+ if (newShape)
+ return fir::SequenceType::get(*newShape, seqTy.getEleTy());
+ return seqTy.getEleTy();
+ })
+ .Case<fir::PointerType, fir::HeapType, fir::ReferenceType, fir::BoxType,
+ fir::ClassType>([&](auto t) -> mlir::Type {
+ using FIRT = decltype(t);
+ return FIRT::get(changeTypeShape(t.getEleTy(), newShape));
+ })
+ .Default([&](mlir::Type t) -> mlir::Type {
+ assert((fir::isa_trivial(t) || llvm::isa<fir::RecordType>(t) ||
+ llvm::isa<mlir::NoneType>(t)) &&
+ "unexpected FIR leaf type");
+ if (newShape)
+ return fir::SequenceType::get(*newShape, t);
+ return t;
+ });
+}
+
+fir::BaseBoxType
+fir::BaseBoxType::getBoxTypeWithNewShape(mlir::Type shapeMold) const {
+ fir::SequenceType seqTy = fir::unwrapUntilSeqType(shapeMold);
+ std::optional<fir::SequenceType::ShapeRef> newShape;
+ if (seqTy)
+ newShape = seqTy.getShape();
+ return mlir::cast<fir::BaseBoxType>(changeTypeShape(*this, newShape));
+}
+
+bool fir::BaseBoxType::isAssumedRank() const {
+ if (auto seqTy =
+ mlir::dyn_cast<fir::SequenceType>(fir::unwrapRefType(getEleTy())))
+ return seqTy.hasUnknownShape();
+ return false;
+}
+
//===----------------------------------------------------------------------===//
// FIROpsDialect
//===----------------------------------------------------------------------===//
diff --git a/flang/test/Lower/HLFIR/assumed-rank-iface-alloc-ptr.f90 b/flang/test/Lower/HLFIR/assumed-rank-iface-alloc-ptr.f90
new file mode 100644
index 000000000000000..1bb5c001ece8815
--- /dev/null
+++ b/flang/test/Lower/HLFIR/assumed-rank-iface-alloc-ptr.f90
@@ -0,0 +1,75 @@
+! Test lowering of calls to interface with pointer or allocatable
+! assumed rank dummy arguments.
+! RUN: bbc -emit-hlfir -o - %s | FileCheck %s
+
+module ifaces_ptr_alloc
+ interface
+ subroutine alloc_assumed_rank(y)
+ real, allocatable :: y(..)
+ end subroutine
+ subroutine pointer_assumed_rank(y)
+ real, optional, pointer :: y(..)
+ end subroutine
+ subroutine pointer_assumed_rank2(y)
+ real, intent(in), pointer :: y(..)
+ end subroutine
+ end interface
+end module
+
+subroutine scalar_alloc_to_assumed_rank(x)
+ use ifaces_ptr_alloc, only : alloc_assumed_rank
+ real, allocatable :: x
+ call alloc_assumed_rank(x)
+end subroutine
+! CHECK-LABEL: func.func @_QPscalar_alloc_to_assumed_rank(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.heap<f32>>> {fir.bindc_name = "x"}) {
+! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<allocatable>, uniq_name = "_QFscalar_alloc_to_assumed_rankEx"} : (!fir.ref<!fir.box<!fir.heap<f32>>>) -> (!fir.ref<!fir.box<!fir.heap<f32>>>, !fir.ref<!fir.box<!fir.heap<f32>>>)
+! CHECK: %[[VAL_2:.*]] = fir.convert %[[VAL_1]]#0 : (!fir.ref<!fir.box<!fir.heap<f32>>>) -> !fir.ref<!fir.box<!fir.heap<!fir.array<*:f32>>>>
+! CHECK: fir.call @_QPalloc_assumed_rank(%[[VAL_2]]) fastmath<contract> : (!fir.ref<!fir.box<!fir.heap<!fir.array<*:f32>>>>) -> ()
+
+subroutine r2_alloc_to_assumed_rank(x)
+ use ifaces_ptr_alloc, only : alloc_assumed_rank
+ real, allocatable :: x(:, :)
+ call alloc_assumed_rank(x)
+end subroutine
+! CHECK-LABEL: func.func @_QPr2_alloc_to_assumed_rank(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>> {fir.bindc_name = "x"}) {
+! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<allocatable>, uniq_name = "_QFr2_alloc_to_assumed_rankEx"} : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>) -> (!fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>)
+! CHECK: %[[VAL_2:.*]] = fir.convert %[[VAL_1]]#0 : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x?xf32>>>>) -> !fir.ref<!fir.box<!fir.heap<!fir.array<*:f32>>>>
+! CHECK: fir.call @_QPalloc_assumed_rank(%[[VAL_2]]) fastmath<contract> : (!fir.ref<!fir.box<!fir.heap<!fir.array<*:f32>>>>) -> ()
+
+subroutine scalar_pointer_to_assumed_rank(x)
+ use ifaces_ptr_alloc, only : pointer_assumed_rank
+ real, pointer :: x
+ call pointer_assumed_rank(x)
+end subroutine
+! CHECK-LABEL: func.func @_QPscalar_pointer_to_assumed_rank(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<f32>>> {fir.bindc_name = "x"}) {
+! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFscalar_pointer_to_assumed_rankEx"} : (!fir.ref<!fir.box<!fir.ptr<f32>>>) -> (!fir.ref<!fir.box<!fir.ptr<f32>>>, !fir.ref<!fir.box<!fir.ptr<f32>>>)
+! CHECK: %[[VAL_2:.*]] = fir.convert %[[VAL_1]]#0 : (!fir.ref<!fir.box<!fir.ptr<f32>>>) -> !fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>
+! CHECK: fir.call @_QPpointer_assumed_rank(%[[VAL_2]]) fastmath<contract> : (!fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>) -> ()
+
+subroutine r2_pointer_to_assumed_rank(x)
+ use ifaces_ptr_alloc, only : pointer_assumed_rank
+ real, pointer :: x(:, :)
+ call pointer_assumed_rank(x)
+end subroutine
+! CHECK-LABEL: func.func @_QPr2_pointer_to_assumed_rank(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>> {fir.bindc_name = "x"}) {
+! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFr2_pointer_to_assumed_rankEx"} : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>) -> (!fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>, !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>)
+! CHECK: %[[VAL_2:.*]] = fir.convert %[[VAL_1]]#0 : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>) -> !fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>
+! CHECK: fir.call @_QPpointer_assumed_rank(%[[VAL_2]]) fastmath<contract> : (!fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>) -> ()
+
+subroutine r2_target_to_pointer_assumed_rank(x)
+ use ifaces_ptr_alloc, only : pointer_assumed_rank2
+ real, target :: x(:, :)
+ call pointer_assumed_rank2(x)
+end subroutine
+! CHECK-LABEL: func.func @_QPr2_target_to_pointer_assumed_rank(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.box<!fir.array<?x?xf32>> {fir.bindc_name = "x", fir.target}) {
+! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.box<!fir.ptr<!fir.array<?x?xf32>>>
+! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<target>, uniq_name = "_QFr2_target_to_pointer_assumed_rankEx"} : (!fir.box<!fir.array<?x?xf32>>) -> (!fir.box<!fir.array<?x?xf32>>, !fir.box<!fir.array<?x?xf32>>)
+! CHECK: %[[VAL_3:.*]] = fir.rebox %[[VAL_2]]#1 : (!fir.box<!fir.array<?x?xf32>>) -> !fir.box<!fir.ptr<!fir.array<?x?xf32>>>
+! CHECK: fir.store %[[VAL_3]] to %[[VAL_1]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>
+! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_1]] : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>) -> !fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>
+! CHECK: fir.call @_QPpointer_assumed_rank2(%[[VAL_4]]) fastmath<contract> : (!fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>) -> ()
diff --git a/flang/test/Lower/HLFIR/assumed-rank-iface.f90 b/flang/test/Lower/HLFIR/assumed-rank-iface.f90
new file mode 100644
index 000000000000000..5df794434844ddd
--- /dev/null
+++ b/flang/test/Lower/HLFIR/assumed-rank-iface.f90
@@ -0,0 +1,141 @@
+! Test lowering of calls to interface with non pointer non allocatable
+! assumed rank dummy arguments.
+! RUN: bbc -emit-hlfir -o - %s | FileCheck %s
+
+module ifaces
+ interface
+ subroutine int_assumed_rank(y)
+ integer :: y(..)
+ end subroutine
+ subroutine int_opt_assumed_rank(y)
+ integer, optional :: y(..)
+ end subroutine
+ subroutine int_assumed_rank_bindc(y) bind(c)
+ integer :: y(..)
+ end subroutine
+ end interface
+end module
+
+subroutine int_scalar_to_assumed_rank(x)
+ use ifaces, only : int_assumed_rank
+ integer :: x
+ call int_assumed_rank(x)
+end subroutine
+! CHECK-LABEL: func.func @_QPint_scalar_to_assumed_rank(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "x"}) {
+! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "_QFint_scalar_to_assumed_rankEx"} : (!fir.ref<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
+! CHECK: %[[VAL_2:.*]] = fir.embox %[[VAL_1]]#0 : (!fir.ref<i32>) -> !fir.box<i32>
+! CHECK: %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (!fir.box<i32>) -> !fir.box<!fir.array<*:i32>>
+! CHECK: fir.call @_QPint_assumed_rank(%[[VAL_3]]) fastmath<contract> : (!fir.box<!fir.array<*:i32>>) -> ()
+
+subroutine int_scalar_to_assumed_rank_bindc(x)
+ use ifaces, only : int_assumed_rank_bindc
+ integer :: x
+ call int_assumed_rank_bindc(x)
+end subroutine
+! CHECK-LABEL: func.func @_QPint_scalar_to_assumed_rank_bindc(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "x"}) {
+! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "_QFint_scalar_to_assumed_rank_bindcEx"} : (!fir.ref<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
+! CHECK: %[[VAL_2:.*]] = fir.embox %[[VAL_1]]#0 : (!fir.ref<i32>) -> !fir.box<i32>
+! CHECK: %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (!fir.box<i32>) -> !fir.box<!fir.array<*:i32>>
+! CHECK: fir.call @int_assumed_rank_bindc(%[[VAL_3]]) fastmath<contract> : (!fir.box<!fir.array<*:i32>>) -> ()
+
+subroutine int_r1_to_assumed_rank(x)
+ use ifaces, only : int_assumed_rank
+ integer :: x(10)
+ call int_assumed_rank(x)
+end subroutine
+! CHECK-LABEL: func.func @_QPint_r1_to_assumed_rank(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.array<10xi32>> {fir.bindc_name = "x"}) {
+! CHECK: %[[VAL_1:.*]] = arith.constant 10 : index
+! CHECK: %[[VAL_2:.*]] = fir.shape %[[VAL_1]] : (index) -> !fir.shape<1>
+! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_0]](%[[VAL_2]]) {uniq_name = "_QFint_r1_to_assumed_rankEx"} : (!fir.ref<!fir.array<10xi32>>, !fir.shape<1>) -> (!fir.ref<!fir.array<10xi32>>, !fir.ref<!fir.array<10xi32>>)
+! CHECK: %[[VAL_4:.*]] = fir.embox %[[VAL_3]]#0(%[[VAL_2]]) : (!fir.ref<!fir.array<10xi32>>, !fir.shape<1>) -> !fir.box<!fir.array<10xi32>>
+! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (!fir.box<!fir.array<10xi32>>) -> !fir.box<!fir.array<*:i32>>
+! CHECK: fir.call @_QPint_assumed_rank(%[[VAL_5]]) fastmath<contract> : (!fir.box<!fir.array<*:i32>>) -> ()
+
+subroutine int_r4_to_assumed_rank(x)
+ use ifaces, only : int_assumed_rank
+ integer :: x(2,3,4,5)
+ call int_assumed_rank(x)
+end subroutine
+! CHECK-LABEL: func.func @_QPint_r4_to_assumed_rank(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.array<2x3x4x5xi32>> {fir.bindc_name = "x"}) {
+! CHECK: %[[VAL_1:.*]] = arith.constant 2 : index
+! CHECK: %[[VAL_2:.*]] = arith.constant 3 : index
+! CHECK: %[[VAL_3:.*]] = arith.constant 4 : index
+! CHECK: %[[VAL_4:.*]] = arith.constant 5 : index
+! CHECK: %[[VAL_5:.*]] = fir.shape %[[VAL_1]], %[[VAL_2]], %[[VAL_3]], %[[VAL_4]] : (index, index, index, index) -> !fir.shape<4>
+! CHECK: %[[VAL_6:.*]]:2 = hlfir.declare %[[VAL_0]](%[[VAL_5]]) {uniq_name = "_QFint_r4_to_assumed_rankEx"} : (!fir.ref<!fir.array<2x3x4x5xi32>>, !fir.shape<4>) -> (!fir.ref<!fir.array<2x3x4x5xi32>>, !fir.ref<!fir.array<2x3x4x5xi32>>)
+! CHECK: %[[VAL_7:.*]] = fir.embox %[[VAL_6]]#0(%[[VAL_5]]) : (!fir.ref<!fir.array<2x3x4x5xi32>>, !fir.shape<4>) -> !fir.box<!fir.array<2x3x4x5xi32>>
+! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (!fir.box<!fir.array<2x3x4x5xi32>>) -> !fir.box<!fir.array<*:i32>>
+! CHECK: fir.call @_QPint_assumed_rank(%[[VAL_8]]) fastmath<contract> : (!fir.box<!fir.array<*:i32>>) -> ()
+
+subroutine int_assumed_shape_to_assumed_rank(x)
+ use ifaces, only : int_assumed_rank
+ integer :: x(:, :)
+ call int_assumed_rank(x)
+end subroutine
+! CHECK-LABEL: func.func @_QPint_assumed_shape_to_assumed_rank(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.box<!fir.array<?x?xi32>> {fir.bindc_name = "x"}) {
+! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "_QFint_assumed_shape_to_assumed_rankEx"} : (!fir.box<!fir.array<?x?xi32>>) -> (!fir.box<!fir.array<?x?xi32>>, !fir.box<!fir.array<?x?xi32>>)
+! CHECK: %[[VAL_2:.*]] = fir.convert %[[VAL_1]]#0 : (!fir.box<!fir.array<?x?xi32>>) -> !fir.box<!fir.array<*:i32>>
+! CHECK: fir.call @_QPint_assumed_rank(%[[VAL_2]]) fastmath<contract> : (!fir.box<!fir.array<*:i32>>) -> ()
+
+subroutine int_assumed_shape_to_assumed_rank_bindc(x)
+ use ifaces, only : int_assumed_rank_bindc
+ integer :: x(:, :)
+ call int_assumed_rank_bindc(x)
+end subroutine
+! CHECK-LABEL: func.func @_QPint_assumed_shape_to_assumed_rank_bindc(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.box<!fir.array<?x?xi32>> {fir.bindc_name = "x"}) {
+! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "_QFint_assumed_shape_to_assumed_rank_bindcEx"} : (!fir.box<!fir.array<?x?xi32>>) -> (!fir.box<!fir.array<?x?xi32>>, !fir.box<!fir.array<?x?xi32>>)
+! CHECK: %[[VAL_2:.*]] = arith.constant 0 : index
+! CHECK: %[[VAL_3:.*]] = fir.shift %[[VAL_2]], %[[VAL_2]] : (index, index) -> !fir.shift<2>
+! CHECK: %[[VAL_4:.*]] = fir.rebox %[[VAL_1]]#0(%[[VAL_3]]) : (!fir.box<!fir.array<?x?xi32>>, !fir.shift<2>) -> !fir.box<!fir.array<?x?xi32>>
+! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (!fir.box<!fir.array<?x?xi32>>) -> !fir.box<!fir.array<*:i32>>
+! CHECK: fir.call @int_assumed_rank_bindc(%[[VAL_5]]) fastmath<contract> : (!fir.box<!fir.array<*:i32>>) -> ()
+
+subroutine int_allocatable_to_assumed_rank(x)
+ use ifaces, only : int_assumed_rank
+ integer, allocatable :: x(:, :)
+ call int_assumed_rank(x)
+end subroutine
+! CHECK-LABEL: func.func @_QPint_allocatable_to_assumed_rank(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xi32>>>> {fir.bindc_name = "x"}) {
+! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<allocatable>, uniq_name = "_QFint_allocatable_to_assumed_rankEx"} : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x?xi32>>>>) -> (!fir.ref<!fir.box<!fir.heap<!fir.array<?x?xi32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xi32>>>>)
+! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xi32>>>>
+! CHECK: %[[VAL_3:.*]] = fir.rebox %[[VAL_2]] : (!fir.box<!fir.heap<!fir.array<?x?xi32>>>) -> !fir.box<!fir.array<?x?xi32>>
+! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.box<!fir.array<?x?xi32>>) -> !fir.box<!fir.array<*:i32>>
+! CHECK: fir.call @_QPint_assumed_rank(%[[VAL_4]]) fastmath<contract> : (!fir.box<!fir.array<*:i32>>) -> ()
+
+subroutine int_allocatable_to_assumed_rank_opt(x)
+ use ifaces, only : int_opt_assumed_rank
+ integer, allocatable :: x(:, :)
+ call int_opt_assumed_rank(x)
+end subroutine
+! CHECK-LABEL: func.func @_QPint_allocatable_to_assumed_rank_opt(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xi32>>>> {fir.bindc_name = "x"}) {
+! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<allocatable>, uniq_name = "_QFint_allocatable_to_assumed_rank_optEx"} : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x?xi32>>>>) -> (!fir.ref<!fir.box<!fir.heap<!fir.array<?x?xi32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xi32>>>>)
+! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_1]]#1 : !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xi32>>>>
+! CHECK: %[[VAL_3:.*]] = fir.box_addr %[[VAL_2]] : (!fir.box<!fir.heap<!fir.array<?x?xi32>>>) -> !fir.heap<!fir.array<?x?xi32>>
+! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.heap<!fir.array<?x?xi32>>) -> i64
+! CHECK: %[[VAL_5:.*]] = arith.constant 0 : i64
+! CHECK: %[[VAL_6:.*]] = arith.cmpi ne, %[[VAL_4]], %[[VAL_5]] : i64
+! CHECK: %[[VAL_7:.*]] = fir.if %[[VAL_6]] -> (!fir.box<!fir.array<?x?xi32>>) {
+! CHECK: %[[VAL_8:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref<!fir.box<!fir.heap<!fir.array<?x?xi32>>>>
+! CHECK: %[[VAL_9:.*]] = fir.rebox %[[VAL_8]] : (!fir.box<!fir.heap<!fir.array<?x?xi32>>>) -> !fir.box<!fir.array<?x?xi32>>
+! CHECK: fir.result %[[VAL_9]] : !fir.box<!fir.array<?x?xi32>>
+! CHECK: } else {
+! CHECK: %[[VAL_10:.*]] = fir.absent !fir.box<!fir.array<?x?xi32>>
+! CHECK: fir.result %[[VAL_10]] : !fir.box<!fir.array<?x?xi32>>
+! CHECK: }
+! CHECK: %[[VAL_11:.*]] = fir.convert %[[VAL_7]] : (!fir.box<!fir.array<?x?xi32>>) -> !fir.box<!fir.array<*:i32>>
+! CHECK: fir.call @_QPint_opt_assumed_rank(%[[VAL_11]]) fastmath<contract> : (!fir.box<!fir.array<*:i32>>) -> ()
+
+! TODO: set assumed size last extent to -1.
+!subroutine int_r2_assumed_size_to_assumed_rank(x)
+! use ifaces, only : int_assumed_rank
+! integer :: x(10, *)
+! call int_assumed_rank(x)
+!end subroutine
diff --git a/flang/test/Lower/HLFIR/ignore-rank-unlimited-polymorphic.f90 b/flang/test/Lower/HLFIR/ignore-rank-unlimited-polymorphic.f90
index b22d82bcd5c6636..952e8f565eb93a1 100644
--- a/flang/test/Lower/HLFIR/ignore-rank-unlimited-polymorphic.f90
+++ b/flang/test/Lower/HLFIR/ignore-rank-unlimited-polymorphic.f90
@@ -65,8 +65,8 @@ end subroutine test_real_2d_pointer
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>> {fir.bindc_name = "x"}) {
! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFtest_real_2d_pointerEx"} : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>) -> (!fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>, !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>)
! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>
-! CHECK: %[[VAL_3:.*]] = fir.rebox %[[VAL_2]] : (!fir.box<!fir.ptr<!fir.array<?x?xf32>>>) -> !fir.class<!fir.ptr<!fir.array<?x?xnone>>>
-! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.class<!fir.ptr<!fir.array<?x?xnone>>>) -> !fir.class<none>
+! CHECK: %[[VAL_3:.*]] = fir.rebox %[[VAL_2]] : (!fir.box<!fir.ptr<!fir.array<?x?xf32>>>) -> !fir.class<!fir.array<?x?xnone>>
+! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.class<!fir.array<?x?xnone>>) -> !fir.class<none>
! CHECK: fir.call @_QPcallee(%[[VAL_4]]) fastmath<contract> : (!fir.class<none>) -> ()
! CHECK: return
! CHECK: }
@@ -102,8 +102,9 @@ end subroutine test_derived_explicit_shape_array
! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_5]] : (!fir.box<!fir.array<10x!fir.type<_QFtest_derived_explicit_shape_arrayTt1{a:!fir.box<!fir.heap<f32>>}>>>) -> !fir.box<none>
! CHECK: %[[VAL_10:.*]] = fir.call @_FortranAInitialize(%[[VAL_8]], %{{.*}}, %{{.*}}) fastmath<contract> : (!fir.box<none>, !fir.ref<i8>, i32) -> none
! CHECK: %[[VAL_11:.*]] = fir.embox %[[VAL_3]]#0(%[[VAL_2]]) : (!fir.ref<!fir.array<10x!fir.type<_QFtest_derived_explicit_shape_arrayTt1{a:!fir.box<!fir.heap<f32>>}>>>, !fir.shape<1>) -> !fir.box<!fir.array<10x!fir.type<_QFtest_derived_explicit_shape_arrayTt1{a:!fir.box<!fir.heap<f32>>}>>>
-! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (!fir.box<!fir.array<10x!fir.type<_QFtest_derived_explicit_shape_arrayTt1{a:!fir.box<!fir.heap<f32>>}>>>) -> !fir.class<none>
-! CHECK: fir.call @_QPcallee(%[[VAL_12]]) fastmath<contract> : (!fir.class<none>) -> ()
+! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (!fir.box<!fir.array<10x!fir.type<_QFtest_derived_explicit_shape_arrayTt1{a:!fir.box<!fir.heap<f32>>}>>>) -> !fir.class<!fir.array<10xnone>>
+! CHECK: %[[VAL_13:.*]] = fir.convert %[[VAL_12]] : (!fir.class<!fir.array<10xnone>>) -> !fir.class<none>
+! CHECK: fir.call @_QPcallee(%[[VAL_13]]) fastmath<contract> : (!fir.class<none>) -> ()
! CHECK: return
! CHECK: }
@@ -116,8 +117,8 @@ end subroutine test_up_allocatable_2d_array
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.class<!fir.heap<!fir.array<?x?xnone>>>> {fir.bindc_name = "x"}) {
! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<allocatable>, uniq_name = "_QFtest_up_allocatable_2d_arrayEx"} : (!fir.ref<!fir.class<!fir.heap<!fir.array<?x?xnone>>>>) -> (!fir.ref<!fir.class<!fir.heap<!fir.array<?x?xnone>>>>, !fir.ref<!fir.class<!fir.heap<!fir.array<?x?xnone>>>>)
! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref<!fir.class<!fir.heap<!fir.array<?x?xnone>>>>
-! CHECK: %[[VAL_3:.*]] = fir.rebox %[[VAL_2]] : (!fir.class<!fir.heap<!fir.array<?x?xnone>>>) -> !fir.class<!fir.heap<!fir.array<?x?xnone>>>
-! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.class<!fir.heap<!fir.array<?x?xnone>>>) -> !fir.class<none>
+! CHECK: %[[VAL_3:.*]] = fir.rebox %[[VAL_2]] : (!fir.class<!fir.heap<!fir.array<?x?xnone>>>) -> !fir.class<!fir.array<?x?xnone>>
+! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.class<!fir.array<?x?xnone>>) -> !fir.class<none>
! CHECK: fir.call @_QPcallee(%[[VAL_4]]) fastmath<contract> : (!fir.class<none>) -> ()
! CHECK: return
! CHECK: }
@@ -131,8 +132,8 @@ end subroutine test_up_pointer_1d_array
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.class<!fir.ptr<!fir.array<?xnone>>>> {fir.bindc_name = "x"}) {
! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFtest_up_pointer_1d_arrayEx"} : (!fir.ref<!fir.class<!fir.ptr<!fir.array<?xnone>>>>) -> (!fir.ref<!fir.class<!fir.ptr<!fir.array<?xnone>>>>, !fir.ref<!fir.class<!fir.ptr<!fir.array<?xnone>>>>)
! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref<!fir.class<!fir.ptr<!fir.array<?xnone>>>>
-! CHECK: %[[VAL_3:.*]] = fir.rebox %[[VAL_2]] : (!fir.class<!fir.ptr<!fir.array<?xnone>>>) -> !fir.class<!fir.ptr<!fir.array<?xnone>>>
-! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.class<!fir.ptr<!fir.array<?xnone>>>) -> !fir.class<none>
+! CHECK: %[[VAL_3:.*]] = fir.rebox %[[VAL_2]] : (!fir.class<!fir.ptr<!fir.array<?xnone>>>) -> !fir.class<!fir.array<?xnone>>
+! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.class<!fir.array<?xnone>>) -> !fir.class<none>
! CHECK: fir.call @_QPcallee(%[[VAL_4]]) fastmath<contract> : (!fir.class<none>) -> ()
! CHECK: return
! CHECK: }
diff --git a/flang/test/Lower/HLFIR/ignore-type-assumed-shape.f90 b/flang/test/Lower/HLFIR/ignore-type-assumed-shape.f90
new file mode 100644
index 000000000000000..3ad74ced61a3b9a
--- /dev/null
+++ b/flang/test/Lower/HLFIR/ignore-type-assumed-shape.f90
@@ -0,0 +1,62 @@
+! Test descriptor dummy argument preparation when the
+! dummy has IGNORE_TKR(t). The descriptor should be prepared
+! according to the actual argument type, but its bounds and
+! attributes should still be set as expected for the dummy.
+! RUN: bbc -emit-hlfir --polymorphic-type -o - %s | FileCheck %s
+
+module tkr_ifaces
+ interface
+ subroutine takes_assumed_shape_ignore_tkr_t(x) bind(c)
+ !dir$ ignore_tkr (t) x
+ integer :: x(:)
+ end subroutine
+ end interface
+end module
+
+subroutine test_ignore_t_1(x)
+ use tkr_ifaces
+ real :: x(10)
+ call takes_assumed_shape_ignore_tkr_t(x)
+end subroutine
+! CHECK-LABEL: func.func @_QPtest_ignore_t_1(
+! CHECK: %[[VAL_5:.*]] = arith.constant 0 : index
+! CHECK: %[[VAL_6:.*]] = fir.shift %[[VAL_5]] : (index) -> !fir.shift<1>
+! CHECK: %[[VAL_7:.*]] = fir.rebox %{{.*}}(%[[VAL_6]]) : (!fir.box<!fir.array<10xf32>>, !fir.shift<1>) -> !fir.box<!fir.array<?xf32>>
+! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (!fir.box<!fir.array<?xf32>>) -> !fir.box<!fir.array<?xi32>>
+! CHECK: fir.call @takes_assumed_shape_ignore_tkr_t(%[[VAL_8]]) fastmath<contract> : (!fir.box<!fir.array<?xi32>>) -> ()
+
+subroutine test_ignore_t_2(x)
+ use tkr_ifaces
+ class(*) :: x(:)
+ call takes_assumed_shape_ignore_tkr_t(x)
+end subroutine
+! CHECK-LABEL: func.func @_QPtest_ignore_t_2(
+! CHECK: %[[VAL_2:.*]] = arith.constant 0 : index
+! CHECK: %[[VAL_3:.*]] = fir.shift %[[VAL_2]] : (index) -> !fir.shift<1>
+! CHECK: %[[VAL_4:.*]] = fir.rebox %{{.*}}(%[[VAL_3]]) : (!fir.class<!fir.array<?xnone>>, !fir.shift<1>) -> !fir.class<!fir.array<?xnone>>
+! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (!fir.class<!fir.array<?xnone>>) -> !fir.box<!fir.array<?xi32>>
+! CHECK: fir.call @takes_assumed_shape_ignore_tkr_t(%[[VAL_5]]) fastmath<contract> : (!fir.box<!fir.array<?xi32>>) -> ()
+
+subroutine test_ignore_t_3(x)
+ use tkr_ifaces
+ real :: x(10)
+ call takes_assumed_shape_ignore_tkr_t(x+1.0)
+end subroutine
+! CHECK-LABEL: func.func @_QPtest_ignore_t_3(
+! CHECK: %[[VAL_12:.*]] = arith.constant 0 : index
+! CHECK: %[[VAL_13:.*]] = fir.shift %[[VAL_12]] : (index) -> !fir.shift<1>
+! CHECK: %[[VAL_14:.*]] = fir.rebox %{{.*}}(%[[VAL_13]]) : (!fir.box<!fir.array<10xf32>>, !fir.shift<1>) -> !fir.box<!fir.array<?xf32>>
+! CHECK: %[[VAL_15:.*]] = fir.convert %[[VAL_14]] : (!fir.box<!fir.array<?xf32>>) -> !fir.box<!fir.array<?xi32>>
+! CHECK: fir.call @takes_assumed_shape_ignore_tkr_t(%[[VAL_15]]) fastmath<contract> : (!fir.box<!fir.array<?xi32>>) -> ()
+
+subroutine test_ignore_t_4(x)
+ use tkr_ifaces
+ real, pointer :: x(:)
+ call takes_assumed_shape_ignore_tkr_t(x)
+end subroutine
+! CHECK-LABEL: func.func @_QPtest_ignore_t_4(
+! CHECK: %[[VAL_3:.*]] = arith.constant 0 : index
+! CHECK: %[[VAL_4:.*]] = fir.shift %[[VAL_3]] : (index) -> !fir.shift<1>
+! CHECK: %[[VAL_5:.*]] = fir.rebox %{{.*}}(%[[VAL_4]]) : (!fir.box<!fir.ptr<!fir.array<?xf32>>>, !fir.shift<1>) -> !fir.box<!fir.array<?xf32>>
+! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (!fir.box<!fir.array<?xf32>>) -> !fir.box<!fir.array<?xi32>>
+! CHECK: fir.call @takes_assumed_shape_ignore_tkr_t(%[[VAL_6]]) fastmath<contract> : (!fir.box<!fir.array<?xi32>>) -> ()
More information about the flang-commits
mailing list