[flang-commits] [flang] [flang] Lower passing non assumed-rank/size to assumed-ranks (PR #79145)
via flang-commits
flang-commits at lists.llvm.org
Fri Jan 26 06:30:21 PST 2024
https://github.com/jeanPerier updated https://github.com/llvm/llvm-project/pull/79145
>From c02829c23b4e94f2c645221d047769081a3d801d Mon Sep 17 00:00:00 2001
From: Jean Perier <jperier at nvidia.com>
Date: Tue, 23 Jan 2024 01:58:13 -0800
Subject: [PATCH 1/5] [flang] Lower passing non assumed-rank/size to
assumed-ranks
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.
Implementation of Fortran procedure with assumed-rank arguments is still
TODO.
test
---
.../flang/Optimizer/Builder/HLFIRTools.h | 3 +
.../include/flang/Optimizer/Dialect/FIRType.h | 7 +
flang/lib/Lower/CallInterface.cpp | 30 ++--
flang/lib/Lower/ConvertCall.cpp | 130 +++++++++++-----
flang/lib/Lower/ConvertExprToHLFIR.cpp | 4 +-
flang/lib/Optimizer/Dialect/FIRType.cpp | 40 +++++
.../HLFIR/assumed-rank-iface-alloc-ptr.f90 | 58 +++++++
flang/test/Lower/HLFIR/assumed-rank-iface.f90 | 141 ++++++++++++++++++
.../ignore-rank-unlimited-polymorphic.f90 | 17 ++-
9 files changed, 368 insertions(+), 62 deletions(-)
create mode 100644 flang/test/Lower/HLFIR/assumed-rank-iface-alloc-ptr.f90
create mode 100644 flang/test/Lower/HLFIR/assumed-rank-iface.f90
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..9e8c802a8d7137a 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);
};
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..ce26aa700f32c5d 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -650,6 +650,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 +866,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 +897,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.
@@ -942,6 +964,18 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
(passingPolymorphicToNonPolymorphic ||
!Fortran::evaluate::IsSimplyContiguous(expr, foldingContext));
+ // 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 dummy is ranked, which allows simple code generation.
+ bool actualIsAssumedRank = actual.isAssumedRank();
+
+ 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());
+
// 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 +986,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 +1015,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 +1035,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 +1049,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 +1069,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 +1083,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 unknwon runtime size of assumed-rank
+ // descriptors.
+ preparedDummy.dummy =
+ builder.createConvert(loc, dummyTypeWithActualRank, addr);
return preparedDummy;
}
@@ -1087,11 +1143,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 +1168,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 +1271,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);
@@ -1277,8 +1331,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 +2239,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 a3ad10978e59861..ce305af2ed262d2 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/Optimizer/Dialect/FIRType.cpp b/flang/lib/Optimizer/Dialect/FIRType.cpp
index 110b3a5e0620e20..0955901b0f3a23b 100644
--- a/flang/lib/Optimizer/Dialect/FIRType.cpp
+++ b/flang/lib/Optimizer/Dialect/FIRType.cpp
@@ -1242,6 +1242,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> ||
+ 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..95835bb0e6a8be9
--- /dev/null
+++ b/flang/test/Lower/HLFIR/assumed-rank-iface-alloc-ptr.f90
@@ -0,0 +1,58 @@
+! 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
+ 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>>>>) -> ()
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: }
>From fd203a09dfac3a034ae8925a265b2107ee4893ee Mon Sep 17 00:00:00 2001
From: Jean Perier <jperier at nvidia.com>
Date: Tue, 23 Jan 2024 07:53:46 -0800
Subject: [PATCH 2/5] fix typo inside assert
---
flang/lib/Optimizer/Dialect/FIRType.cpp | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/flang/lib/Optimizer/Dialect/FIRType.cpp b/flang/lib/Optimizer/Dialect/FIRType.cpp
index 0955901b0f3a23b..074d1b97968bf9f 100644
--- a/flang/lib/Optimizer/Dialect/FIRType.cpp
+++ b/flang/lib/Optimizer/Dialect/FIRType.cpp
@@ -1257,7 +1257,7 @@ changeTypeShape(mlir::Type type,
return FIRT::get(changeTypeShape(t.getEleTy(), newShape));
})
.Default([&](mlir::Type t) -> mlir::Type {
- assert((fir::isa_trivial(t) || llvm::isa<fir::RecordType> ||
+ assert((fir::isa_trivial(t) || llvm::isa<fir::RecordType>(t) ||
llvm::isa<mlir::NoneType>(t)) &&
"unexpected FIR leaf type");
if (newShape)
>From f82b2f75ba4353c00728590086d0a00081984cad Mon Sep 17 00:00:00 2001
From: jeanPerier <jean.perier.polytechnique at gmail.com>
Date: Wed, 24 Jan 2024 09:04:15 +0100
Subject: [PATCH 3/5] Fix typos in comments
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
Co-authored-by: Valentin Clement (バレンタイン クレメン) <clementval at gmail.com>
---
flang/lib/Lower/ConvertCall.cpp | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index ce26aa700f32c5d..c7076e10b0a1d96 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -966,7 +966,7 @@ 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 dummy is ranked, which allows simple code generation.
+ // the actual argument is ranked, which allows simple code generation.
bool actualIsAssumedRank = actual.isAssumedRank();
mlir::Type dummyTypeWithActualRank = dummyType;
@@ -1128,7 +1128,7 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
// 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 unknwon runtime size of assumed-rank
+ // causing extra runtime costs due to the unknown runtime size of assumed-rank
// descriptors.
preparedDummy.dummy =
builder.createConvert(loc, dummyTypeWithActualRank, addr);
>From a515059f588ff705b5c3a29462fc2b478a939f2c Mon Sep 17 00:00:00 2001
From: Jean Perier <jperier at nvidia.com>
Date: Thu, 25 Jan 2024 06:04:32 -0800
Subject: [PATCH 4/5] add todo for assumed-rank variables
The current patch only covers the case where the procedure
with assumed rank arguments is not implemented in Fortran.
---
flang/lib/Lower/ConvertVariable.cpp | 3 +++
1 file changed, 3 insertions(+)
diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp
index dd024a0a1ec7927..e496975867d4379 100644
--- a/flang/lib/Lower/ConvertVariable.cpp
+++ b/flang/lib/Lower/ConvertVariable.cpp
@@ -1821,6 +1821,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);
>From 9487e56cf1c3214936a5653f9284f77a43d566d4 Mon Sep 17 00:00:00 2001
From: Jean Perier <jperier at nvidia.com>
Date: Fri, 26 Jan 2024 02:43:07 -0800
Subject: [PATCH 5/5] handle ignore_tkr(t) case when reboxing is needed
Enforcing the 18.5.3 exposed a weakness in ignore_tkr(t) that could lead
to invalid fir.rebox being generated (using the dummy type was output
which is not the same as the input type which is the type of the actual
argument). Always prepare the dummy descriptor according to the actual
argument type in case of ignore_tkr(t).
---
.../flang/Optimizer/Builder/FIRBuilder.h | 3 +-
.../include/flang/Optimizer/Dialect/FIRType.h | 7 +++
flang/lib/Lower/ConvertCall.cpp | 35 +++++++++--
flang/lib/Optimizer/Builder/FIRBuilder.cpp | 23 +++----
flang/lib/Optimizer/Dialect/FIRType.cpp | 27 ++++++++
.../HLFIR/assumed-rank-iface-alloc-ptr.f90 | 17 +++++
.../Lower/HLFIR/ignore-type-assumed-shape.f90 | 62 +++++++++++++++++++
7 files changed, 157 insertions(+), 17 deletions(-)
create mode 100644 flang/test/Lower/HLFIR/ignore-type-assumed-shape.f90
diff --git a/flang/include/flang/Optimizer/Builder/FIRBuilder.h b/flang/include/flang/Optimizer/Builder/FIRBuilder.h
index b5b2c99810b15bb..195baabe9139e50 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/Dialect/FIRType.h b/flang/include/flang/Optimizer/Dialect/FIRType.h
index 9e8c802a8d7137a..75106b3028ac903 100644
--- a/flang/include/flang/Optimizer/Dialect/FIRType.h
+++ b/flang/include/flang/Optimizer/Dialect/FIRType.h
@@ -435,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/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index c7076e10b0a1d96..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);
@@ -944,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
@@ -964,17 +972,24 @@ 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.
- bool actualIsAssumedRank = actual.isAssumedRank();
-
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
@@ -1315,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{},
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 074d1b97968bf9f..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 {
diff --git a/flang/test/Lower/HLFIR/assumed-rank-iface-alloc-ptr.f90 b/flang/test/Lower/HLFIR/assumed-rank-iface-alloc-ptr.f90
index 95835bb0e6a8be9..1bb5c001ece8815 100644
--- a/flang/test/Lower/HLFIR/assumed-rank-iface-alloc-ptr.f90
+++ b/flang/test/Lower/HLFIR/assumed-rank-iface-alloc-ptr.f90
@@ -10,6 +10,9 @@ subroutine alloc_assumed_rank(y)
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
@@ -56,3 +59,17 @@ subroutine r2_pointer_to_assumed_rank(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/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