Skip to content

[flang] Handle OPTIONAL polymorphic captured in internal procedures #82042

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 1 commit into from
Feb 28, 2024
Merged

[flang] Handle OPTIONAL polymorphic captured in internal procedures #82042

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
64 changes: 49 additions & 15 deletions flang/lib/Lower/HostAssociations.cpp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -247,29 +247,62 @@ class CapturedCharacterScalars
}
};

/// Class defining how polymorphic entities are captured in internal procedures.
/// Polymorphic entities are always boxed as a fir.class box.
class CapturedPolymorphic : public CapturedSymbols<CapturedPolymorphic> {
/// Class defining how polymorphic scalar entities are captured in internal
/// procedures. Polymorphic entities are always boxed as a fir.class box.
/// Polymorphic array can be handled in CapturedArrays directly
class CapturedPolymorphicScalar
: public CapturedSymbols<CapturedPolymorphicScalar> {
public:
static mlir::Type getType(Fortran::lower::AbstractConverter &converter,
const Fortran::semantics::Symbol &sym) {
return converter.genType(sym);
}
static void instantiateHostTuple(const InstantiateHostTuple &args,
Fortran::lower::AbstractConverter &converter,
const Fortran::semantics::Symbol &) {
const Fortran::semantics::Symbol &sym) {
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
mlir::Location loc = args.loc;
mlir::Type typeInTuple = fir::dyn_cast_ptrEleTy(args.addrInTuple.getType());
assert(typeInTuple && "addrInTuple must be an address");
mlir::Value castBox = builder.createConvert(args.loc, typeInTuple,
fir::getBase(args.hostValue));
builder.create<fir::StoreOp>(args.loc, castBox, args.addrInTuple);
if (Fortran::semantics::IsOptional(sym)) {
auto isPresent =
builder.create<fir::IsPresentOp>(loc, builder.getI1Type(), castBox);
builder.genIfThenElse(loc, isPresent)
.genThen([&]() {
builder.create<fir::StoreOp>(loc, castBox, args.addrInTuple);
})
.genElse([&]() {
mlir::Value null = fir::factory::createUnallocatedBox(
builder, loc, typeInTuple,
/*nonDeferredParams=*/mlir::ValueRange{});
builder.create<fir::StoreOp>(loc, null, args.addrInTuple);
})
.end();
} else {
builder.create<fir::StoreOp>(loc, castBox, args.addrInTuple);
}
}
static void getFromTuple(const GetFromTuple &args,
Fortran::lower::AbstractConverter &converter,
const Fortran::semantics::Symbol &sym,
const Fortran::lower::BoxAnalyzer &ba) {
bindCapturedSymbol(sym, args.valueInTuple, converter, args.symMap);
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
mlir::Location loc = args.loc;
mlir::Value box = args.valueInTuple;
if (Fortran::semantics::IsOptional(sym)) {
auto boxTy = box.getType().cast<fir::BaseBoxType>();
auto eleTy = boxTy.getEleTy();
if (!fir::isa_ref_type(eleTy))
eleTy = builder.getRefType(eleTy);
auto addr = builder.create<fir::BoxAddrOp>(loc, eleTy, box);
mlir::Value isPresent = builder.genIsNotNullAddr(loc, addr);
auto absentBox = builder.create<fir::AbsentOp>(loc, boxTy);
box =
builder.create<mlir::arith::SelectOp>(loc, isPresent, box, absentBox);
}
bindCapturedSymbol(sym, box, converter, args.symMap);
}
};

Expand Down Expand Up @@ -342,7 +375,12 @@ class CapturedArrays : public CapturedSymbols<CapturedArrays> {
static mlir::Type getType(Fortran::lower::AbstractConverter &converter,
const Fortran::semantics::Symbol &sym) {
mlir::Type type = converter.genType(sym);
assert(type.isa<fir::SequenceType>() && "must be a sequence type");
bool isPolymorphic = Fortran::semantics::IsPolymorphic(sym);
assert(type.isa<fir::SequenceType>() ||
(isPolymorphic && type.isa<fir::ClassType>()) &&
"must be a sequence type");
if (isPolymorphic)
return type;
return fir::BoxType::get(type);
}

Expand Down Expand Up @@ -410,13 +448,13 @@ class CapturedArrays : public CapturedSymbols<CapturedArrays> {
fir::factory::readBoxValue(builder, loc, boxValue),
converter, args.symMap);
} else {
// Keep variable as a fir.box.
// Keep variable as a fir.box/fir.class.
// If this is an optional that is absent, the fir.box needs to be an
// AbsentOp result, otherwise it will not work properly with IsPresentOp
// (absent boxes are null descriptor addresses, not descriptors containing
// a null base address).
if (Fortran::semantics::IsOptional(sym)) {
auto boxTy = box.getType().cast<fir::BoxType>();
auto boxTy = box.getType().cast<fir::BaseBoxType>();
auto eleTy = boxTy.getEleTy();
if (!fir::isa_ref_type(eleTy))
eleTy = builder.getRefType(eleTy);
Expand Down Expand Up @@ -470,14 +508,10 @@ walkCaptureCategories(T visitor, Fortran::lower::AbstractConverter &converter,
ba.analyze(sym);
if (Fortran::semantics::IsAllocatableOrPointer(sym))
return CapturedAllocatableAndPointer::visit(visitor, converter, sym, ba);
if (Fortran::semantics::IsPolymorphic(sym)) {
if (ba.isArray() && !ba.lboundIsAllOnes())
TODO(converter.genLocation(sym.name()),
"polymorphic array with non default lower bound");
return CapturedPolymorphic::visit(visitor, converter, sym, ba);
}
if (ba.isArray())
return CapturedArrays::visit(visitor, converter, sym, ba);
if (Fortran::semantics::IsPolymorphic(sym))
return CapturedPolymorphicScalar::visit(visitor, converter, sym, ba);
if (ba.isChar())
return CapturedCharacterScalars::visit(visitor, converter, sym, ba);
assert(ba.isTrivial() && "must be trivial scalar");
Expand Down
2 changes: 1 addition & 1 deletion flang/lib/Optimizer/Builder/MutableBox.cpp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -674,7 +674,7 @@ void fir::factory::disassociateMutableBox(fir::FirOpBuilder &builder,
// 7.3.2.3 point 7. The dynamic type of a disassociated pointer is the
// same as its declared type.
auto boxTy = box.getBoxTy().dyn_cast<fir::BaseBoxType>();
auto eleTy = fir::dyn_cast_ptrOrBoxEleTy(boxTy.getEleTy());
auto eleTy = fir::unwrapPassByRefType(boxTy.getEleTy());
mlir::Type derivedType = fir::getDerivedType(eleTy);
if (auto recTy = derivedType.dyn_cast<fir::RecordType>()) {
fir::runtime::genNullifyDerivedType(builder, loc, box.getAddr(), recTy,
Expand Down
81 changes: 81 additions & 0 deletions flang/test/Lower/HLFIR/internal-procedures-polymorphic.f90
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,81 @@
! Test lowering of internal procedure capturing OPTIONAL polymorphic
! objects.
! RUN: bbc -emit-hlfir --polymorphic-type -o - %s -I nw | FileCheck %s


module captured_optional_polymorphic
type sometype
end type
contains
subroutine test(x, y)
class(sometype), optional :: x
class(sometype), optional :: y(2:)
call internal()
contains
subroutine internal()
if (present(x).and.present(y)) then
print *, same_type_as(x, y)
end if
end subroutine
end
end module

! CHECK-LABEL: func.func @_QMcaptured_optional_polymorphicPtest(
! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare{{.*}}Ex
! CHECK: %[[VAL_3:.*]] = arith.constant 2 : i64
! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (i64) -> index
! CHECK: %[[VAL_5:.*]] = fir.shift %[[VAL_4]] : (index) -> !fir.shift<1>
! CHECK: %[[VAL_6:.*]]:2 = hlfir.declare{{.*}}Ey
! CHECK: %[[VAL_7:.*]] = fir.alloca tuple<!fir.class<!fir.type<_QMcaptured_optional_polymorphicTsometype>>, !fir.class<!fir.array<?x!fir.type<_QMcaptured_optional_polymorphicTsometype>>>>
! CHECK: %[[VAL_8:.*]] = arith.constant 0 : i32
! CHECK: %[[VAL_9:.*]] = fir.coordinate_of %[[VAL_7]], %[[VAL_8]]
! CHECK: %[[VAL_10:.*]] = fir.is_present %[[VAL_2]]#1 : (!fir.class<!fir.type<_QMcaptured_optional_polymorphicTsometype>>) -> i1
! CHECK: fir.if %[[VAL_10]] {
! CHECK: fir.store %[[VAL_2]]#1 to %[[VAL_9]] : !fir.ref<!fir.class<!fir.type<_QMcaptured_optional_polymorphicTsometype>>>
! CHECK: } else {
! CHECK: %[[VAL_11:.*]] = fir.zero_bits !fir.ref<!fir.type<_QMcaptured_optional_polymorphicTsometype>>
! CHECK: %[[VAL_12:.*]] = fir.embox %[[VAL_11]] : (!fir.ref<!fir.type<_QMcaptured_optional_polymorphicTsometype>>) -> !fir.class<!fir.type<_QMcaptured_optional_polymorphicTsometype>>
! CHECK: fir.store %[[VAL_12]] to %[[VAL_9]] : !fir.ref<!fir.class<!fir.type<_QMcaptured_optional_polymorphicTsometype>>>
! CHECK: }
! CHECK: %[[VAL_13:.*]] = arith.constant 1 : i32
! CHECK: %[[VAL_14:.*]] = fir.coordinate_of %[[VAL_7]], %[[VAL_13]]
! CHECK: %[[VAL_15:.*]] = fir.is_present %[[VAL_6]]#1 : (!fir.class<!fir.array<?x!fir.type<_QMcaptured_optional_polymorphicTsometype>>>) -> i1
! CHECK: fir.if %[[VAL_15]] {
! CHECK: %[[VAL_16:.*]] = fir.shift %[[VAL_4]] : (index) -> !fir.shift<1>
! CHECK: %[[VAL_17:.*]] = fir.rebox %[[VAL_6]]#1(%[[VAL_16]]) : (!fir.class<!fir.array<?x!fir.type<_QMcaptured_optional_polymorphicTsometype>>>, !fir.shift<1>) -> !fir.class<!fir.array<?x!fir.type<_QMcaptured_optional_polymorphicTsometype>>>
! CHECK: fir.store %[[VAL_17]] to %[[VAL_14]] : !fir.ref<!fir.class<!fir.array<?x!fir.type<_QMcaptured_optional_polymorphicTsometype>>>>
! CHECK: } else {
! CHECK: %[[VAL_18:.*]] = fir.type_desc !fir.type<_QMcaptured_optional_polymorphicTsometype>
! CHECK: %[[VAL_19:.*]] = fir.convert %[[VAL_14]] : (!fir.ref<!fir.class<!fir.array<?x!fir.type<_QMcaptured_optional_polymorphicTsometype>>>>) -> !fir.ref<!fir.box<none>>
! CHECK: %[[VAL_20:.*]] = fir.convert %[[VAL_18]] : (!fir.tdesc<!fir.type<_QMcaptured_optional_polymorphicTsometype>>) -> !fir.ref<none>
! CHECK: %[[VAL_21:.*]] = arith.constant 1 : i32
! CHECK: %[[VAL_22:.*]] = arith.constant 0 : i32
! CHECK: %[[VAL_23:.*]] = fir.call @_FortranAPointerNullifyDerived(%[[VAL_19]], %[[VAL_20]], %[[VAL_21]], %[[VAL_22]]) fastmath<contract> : (!fir.ref<!fir.box<none>>, !fir.ref<none>, i32, i32) -> none
! CHECK: }
! CHECK: fir.call @_QMcaptured_optional_polymorphicFtestPinternal(%[[VAL_7]])

! CHECK-LABEL: func.func{{.*}} @_QMcaptured_optional_polymorphicFtestPinternal(
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<tuple<{{.*}}>>
! CHECK: %[[VAL_1:.*]] = arith.constant 0 : i32
! CHECK: %[[VAL_2:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_1]]
! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_2]] : !fir.ref<!fir.class<!fir.type<_QMcaptured_optional_polymorphicTsometype>>>
! CHECK: %[[VAL_4:.*]] = fir.box_addr %[[VAL_3]] : (!fir.class<!fir.type<_QMcaptured_optional_polymorphicTsometype>>) -> !fir.ref<!fir.type<_QMcaptured_optional_polymorphicTsometype>>
! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (!fir.ref<!fir.type<_QMcaptured_optional_polymorphicTsometype>>) -> i64
! CHECK: %[[VAL_6:.*]] = arith.constant 0 : i64
! CHECK: %[[VAL_7:.*]] = arith.cmpi ne, %[[VAL_5]], %[[VAL_6]] : i64
! CHECK: %[[VAL_8:.*]] = fir.absent !fir.class<!fir.type<_QMcaptured_optional_polymorphicTsometype>>
! CHECK: %[[VAL_9:.*]] = arith.select %[[VAL_7]], %[[VAL_3]], %[[VAL_8]] : !fir.class<!fir.type<_QMcaptured_optional_polymorphicTsometype>>
! CHECK: %[[VAL_10:.*]]:2 = hlfir.declare %[[VAL_9]] {fortran_attrs = #fir.var_attrs<optional, host_assoc>, {{.*}}Ex
! CHECK: %[[VAL_11:.*]] = arith.constant 1 : i32
! CHECK: %[[VAL_12:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_11]]
! CHECK: %[[VAL_13:.*]] = fir.load %[[VAL_12]] : !fir.ref<!fir.class<!fir.array<?x!fir.type<_QMcaptured_optional_polymorphicTsometype>>>>
! CHECK: %[[VAL_14:.*]] = arith.constant 0 : index
! CHECK: %[[VAL_15:.*]]:3 = fir.box_dims %[[VAL_13]], %[[VAL_14]]
! CHECK: %[[VAL_16:.*]] = fir.box_addr %[[VAL_13]]
! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_16]] : (!fir.ref<!fir.array<?x!fir.type<_QMcaptured_optional_polymorphicTsometype>>>) -> i64
! CHECK: %[[VAL_18:.*]] = arith.constant 0 : i64
! CHECK: %[[VAL_19:.*]] = arith.cmpi ne, %[[VAL_17]], %[[VAL_18]] : i64
! CHECK: %[[VAL_20:.*]] = fir.absent !fir.class<!fir.array<?x!fir.type<_QMcaptured_optional_polymorphicTsometype>>>
! CHECK: %[[VAL_21:.*]] = arith.select %[[VAL_19]], %[[VAL_13]], %[[VAL_20]] : !fir.class<!fir.array<?x!fir.type<_QMcaptured_optional_polymorphicTsometype>>>
! CHECK: %[[VAL_22:.*]] = fir.shift %[[VAL_15]]#0 : (index) -> !fir.shift<1>
! CHECK: %[[VAL_23:.*]]:2 = hlfir.declare %[[VAL_21]](%[[VAL_22]]) {fortran_attrs = #fir.var_attrs<optional, host_assoc>, {{.*}}Ey