Skip to content

Commit f81d5e5

Browse files
jeanPerierjeanPerier
authored
[flang] Handle OPTIONAL polymorphic captured in internal procedures (#82042)
The current code was doing an unconditional `fir.store %optional_box to %host_link` which caused a crash when %optional_box is absent because is is attempting to copy a descriptor from a null address. Add code to conditionally do the copy at runtime. The polymorphic array case with lower bounds can be handled with the array case that already deals with descriptor argument with a few modifications, just use that.
1 parent 28c29fb commit f81d5e5

File tree

3 files changed

+131
-16
lines changed

3 files changed

+131
-16
lines changed

‎flang/lib/Lower/HostAssociations.cpp

Lines changed: 49 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -247,29 +247,62 @@ class CapturedCharacterScalars
247247
}
248248
};
249249

250-
/// Class defining how polymorphic entities are captured in internal procedures.
251-
/// Polymorphic entities are always boxed as a fir.class box.
252-
class CapturedPolymorphic : public CapturedSymbols<CapturedPolymorphic> {
250+
/// Class defining how polymorphic scalar entities are captured in internal
251+
/// procedures. Polymorphic entities are always boxed as a fir.class box.
252+
/// Polymorphic array can be handled in CapturedArrays directly
253+
class CapturedPolymorphicScalar
254+
: public CapturedSymbols<CapturedPolymorphicScalar> {
253255
public:
254256
static mlir::Type getType(Fortran::lower::AbstractConverter &converter,
255257
const Fortran::semantics::Symbol &sym) {
256258
return converter.genType(sym);
257259
}
258260
static void instantiateHostTuple(const InstantiateHostTuple &args,
259261
Fortran::lower::AbstractConverter &converter,
260-
const Fortran::semantics::Symbol &) {
262+
const Fortran::semantics::Symbol &sym) {
261263
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
264+
mlir::Location loc = args.loc;
262265
mlir::Type typeInTuple = fir::dyn_cast_ptrEleTy(args.addrInTuple.getType());
263266
assert(typeInTuple && "addrInTuple must be an address");
264267
mlir::Value castBox = builder.createConvert(args.loc, typeInTuple,
265268
fir::getBase(args.hostValue));
266-
builder.create<fir::StoreOp>(args.loc, castBox, args.addrInTuple);
269+
if (Fortran::semantics::IsOptional(sym)) {
270+
auto isPresent =
271+
builder.create<fir::IsPresentOp>(loc, builder.getI1Type(), castBox);
272+
builder.genIfThenElse(loc, isPresent)
273+
.genThen([&]() {
274+
builder.create<fir::StoreOp>(loc, castBox, args.addrInTuple);
275+
})
276+
.genElse([&]() {
277+
mlir::Value null = fir::factory::createUnallocatedBox(
278+
builder, loc, typeInTuple,
279+
/*nonDeferredParams=*/mlir::ValueRange{});
280+
builder.create<fir::StoreOp>(loc, null, args.addrInTuple);
281+
})
282+
.end();
283+
} else {
284+
builder.create<fir::StoreOp>(loc, castBox, args.addrInTuple);
285+
}
267286
}
268287
static void getFromTuple(const GetFromTuple &args,
269288
Fortran::lower::AbstractConverter &converter,
270289
const Fortran::semantics::Symbol &sym,
271290
const Fortran::lower::BoxAnalyzer &ba) {
272-
bindCapturedSymbol(sym, args.valueInTuple, converter, args.symMap);
291+
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
292+
mlir::Location loc = args.loc;
293+
mlir::Value box = args.valueInTuple;
294+
if (Fortran::semantics::IsOptional(sym)) {
295+
auto boxTy = box.getType().cast<fir::BaseBoxType>();
296+
auto eleTy = boxTy.getEleTy();
297+
if (!fir::isa_ref_type(eleTy))
298+
eleTy = builder.getRefType(eleTy);
299+
auto addr = builder.create<fir::BoxAddrOp>(loc, eleTy, box);
300+
mlir::Value isPresent = builder.genIsNotNullAddr(loc, addr);
301+
auto absentBox = builder.create<fir::AbsentOp>(loc, boxTy);
302+
box =
303+
builder.create<mlir::arith::SelectOp>(loc, isPresent, box, absentBox);
304+
}
305+
bindCapturedSymbol(sym, box, converter, args.symMap);
273306
}
274307
};
275308

@@ -342,7 +375,12 @@ class CapturedArrays : public CapturedSymbols<CapturedArrays> {
342375
static mlir::Type getType(Fortran::lower::AbstractConverter &converter,
343376
const Fortran::semantics::Symbol &sym) {
344377
mlir::Type type = converter.genType(sym);
345-
assert(type.isa<fir::SequenceType>() && "must be a sequence type");
378+
bool isPolymorphic = Fortran::semantics::IsPolymorphic(sym);
379+
assert(type.isa<fir::SequenceType>() ||
380+
(isPolymorphic && type.isa<fir::ClassType>()) &&
381+
"must be a sequence type");
382+
if (isPolymorphic)
383+
return type;
346384
return fir::BoxType::get(type);
347385
}
348386

@@ -410,13 +448,13 @@ class CapturedArrays : public CapturedSymbols<CapturedArrays> {
410448
fir::factory::readBoxValue(builder, loc, boxValue),
411449
converter, args.symMap);
412450
} else {
413-
// Keep variable as a fir.box.
451+
// Keep variable as a fir.box/fir.class.
414452
// If this is an optional that is absent, the fir.box needs to be an
415453
// AbsentOp result, otherwise it will not work properly with IsPresentOp
416454
// (absent boxes are null descriptor addresses, not descriptors containing
417455
// a null base address).
418456
if (Fortran::semantics::IsOptional(sym)) {
419-
auto boxTy = box.getType().cast<fir::BoxType>();
457+
auto boxTy = box.getType().cast<fir::BaseBoxType>();
420458
auto eleTy = boxTy.getEleTy();
421459
if (!fir::isa_ref_type(eleTy))
422460
eleTy = builder.getRefType(eleTy);
@@ -470,14 +508,10 @@ walkCaptureCategories(T visitor, Fortran::lower::AbstractConverter &converter,
470508
ba.analyze(sym);
471509
if (Fortran::semantics::IsAllocatableOrPointer(sym))
472510
return CapturedAllocatableAndPointer::visit(visitor, converter, sym, ba);
473-
if (Fortran::semantics::IsPolymorphic(sym)) {
474-
if (ba.isArray() && !ba.lboundIsAllOnes())
475-
TODO(converter.genLocation(sym.name()),
476-
"polymorphic array with non default lower bound");
477-
return CapturedPolymorphic::visit(visitor, converter, sym, ba);
478-
}
479511
if (ba.isArray())
480512
return CapturedArrays::visit(visitor, converter, sym, ba);
513+
if (Fortran::semantics::IsPolymorphic(sym))
514+
return CapturedPolymorphicScalar::visit(visitor, converter, sym, ba);
481515
if (ba.isChar())
482516
return CapturedCharacterScalars::visit(visitor, converter, sym, ba);
483517
assert(ba.isTrivial() && "must be trivial scalar");

‎flang/lib/Optimizer/Builder/MutableBox.cpp

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -674,7 +674,7 @@ void fir::factory::disassociateMutableBox(fir::FirOpBuilder &builder,
674674
// 7.3.2.3 point 7. The dynamic type of a disassociated pointer is the
675675
// same as its declared type.
676676
auto boxTy = box.getBoxTy().dyn_cast<fir::BaseBoxType>();
677-
auto eleTy = fir::dyn_cast_ptrOrBoxEleTy(boxTy.getEleTy());
677+
auto eleTy = fir::unwrapPassByRefType(boxTy.getEleTy());
678678
mlir::Type derivedType = fir::getDerivedType(eleTy);
679679
if (auto recTy = derivedType.dyn_cast<fir::RecordType>()) {
680680
fir::runtime::genNullifyDerivedType(builder, loc, box.getAddr(), recTy,

‎flang/test/Lower/HLFIR/internal-procedures-polymorphic.f90

Lines changed: 81 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,81 @@
1+
! Test lowering of internal procedure capturing OPTIONAL polymorphic
2+
! objects.
3+
! RUN: bbc -emit-hlfir --polymorphic-type -o - %s -I nw | FileCheck %s
4+
5+
6+
module captured_optional_polymorphic
7+
type sometype
8+
end type
9+
contains
10+
subroutine test(x, y)
11+
class(sometype), optional :: x
12+
class(sometype), optional :: y(2:)
13+
call internal()
14+
contains
15+
subroutine internal()
16+
if (present(x).and.present(y)) then
17+
print *, same_type_as(x, y)
18+
end if
19+
end subroutine
20+
end
21+
end module
22+
23+
! CHECK-LABEL: func.func @_QMcaptured_optional_polymorphicPtest(
24+
! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare{{.*}}Ex
25+
! CHECK: %[[VAL_3:.*]] = arith.constant 2 : i64
26+
! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (i64) -> index
27+
! CHECK: %[[VAL_5:.*]] = fir.shift %[[VAL_4]] : (index) -> !fir.shift<1>
28+
! CHECK: %[[VAL_6:.*]]:2 = hlfir.declare{{.*}}Ey
29+
! CHECK: %[[VAL_7:.*]] = fir.alloca tuple<!fir.class<!fir.type<_QMcaptured_optional_polymorphicTsometype>>, !fir.class<!fir.array<?x!fir.type<_QMcaptured_optional_polymorphicTsometype>>>>
30+
! CHECK: %[[VAL_8:.*]] = arith.constant 0 : i32
31+
! CHECK: %[[VAL_9:.*]] = fir.coordinate_of %[[VAL_7]], %[[VAL_8]]
32+
! CHECK: %[[VAL_10:.*]] = fir.is_present %[[VAL_2]]#1 : (!fir.class<!fir.type<_QMcaptured_optional_polymorphicTsometype>>) -> i1
33+
! CHECK: fir.if %[[VAL_10]] {
34+
! CHECK: fir.store %[[VAL_2]]#1 to %[[VAL_9]] : !fir.ref<!fir.class<!fir.type<_QMcaptured_optional_polymorphicTsometype>>>
35+
! CHECK: } else {
36+
! CHECK: %[[VAL_11:.*]] = fir.zero_bits !fir.ref<!fir.type<_QMcaptured_optional_polymorphicTsometype>>
37+
! CHECK: %[[VAL_12:.*]] = fir.embox %[[VAL_11]] : (!fir.ref<!fir.type<_QMcaptured_optional_polymorphicTsometype>>) -> !fir.class<!fir.type<_QMcaptured_optional_polymorphicTsometype>>
38+
! CHECK: fir.store %[[VAL_12]] to %[[VAL_9]] : !fir.ref<!fir.class<!fir.type<_QMcaptured_optional_polymorphicTsometype>>>
39+
! CHECK: }
40+
! CHECK: %[[VAL_13:.*]] = arith.constant 1 : i32
41+
! CHECK: %[[VAL_14:.*]] = fir.coordinate_of %[[VAL_7]], %[[VAL_13]]
42+
! CHECK: %[[VAL_15:.*]] = fir.is_present %[[VAL_6]]#1 : (!fir.class<!fir.array<?x!fir.type<_QMcaptured_optional_polymorphicTsometype>>>) -> i1
43+
! CHECK: fir.if %[[VAL_15]] {
44+
! CHECK: %[[VAL_16:.*]] = fir.shift %[[VAL_4]] : (index) -> !fir.shift<1>
45+
! 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>>>
46+
! CHECK: fir.store %[[VAL_17]] to %[[VAL_14]] : !fir.ref<!fir.class<!fir.array<?x!fir.type<_QMcaptured_optional_polymorphicTsometype>>>>
47+
! CHECK: } else {
48+
! CHECK: %[[VAL_18:.*]] = fir.type_desc !fir.type<_QMcaptured_optional_polymorphicTsometype>
49+
! CHECK: %[[VAL_19:.*]] = fir.convert %[[VAL_14]] : (!fir.ref<!fir.class<!fir.array<?x!fir.type<_QMcaptured_optional_polymorphicTsometype>>>>) -> !fir.ref<!fir.box<none>>
50+
! CHECK: %[[VAL_20:.*]] = fir.convert %[[VAL_18]] : (!fir.tdesc<!fir.type<_QMcaptured_optional_polymorphicTsometype>>) -> !fir.ref<none>
51+
! CHECK: %[[VAL_21:.*]] = arith.constant 1 : i32
52+
! CHECK: %[[VAL_22:.*]] = arith.constant 0 : i32
53+
! 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
54+
! CHECK: }
55+
! CHECK: fir.call @_QMcaptured_optional_polymorphicFtestPinternal(%[[VAL_7]])
56+
57+
! CHECK-LABEL: func.func{{.*}} @_QMcaptured_optional_polymorphicFtestPinternal(
58+
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<tuple<{{.*}}>>
59+
! CHECK: %[[VAL_1:.*]] = arith.constant 0 : i32
60+
! CHECK: %[[VAL_2:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_1]]
61+
! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_2]] : !fir.ref<!fir.class<!fir.type<_QMcaptured_optional_polymorphicTsometype>>>
62+
! CHECK: %[[VAL_4:.*]] = fir.box_addr %[[VAL_3]] : (!fir.class<!fir.type<_QMcaptured_optional_polymorphicTsometype>>) -> !fir.ref<!fir.type<_QMcaptured_optional_polymorphicTsometype>>
63+
! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : (!fir.ref<!fir.type<_QMcaptured_optional_polymorphicTsometype>>) -> i64
64+
! CHECK: %[[VAL_6:.*]] = arith.constant 0 : i64
65+
! CHECK: %[[VAL_7:.*]] = arith.cmpi ne, %[[VAL_5]], %[[VAL_6]] : i64
66+
! CHECK: %[[VAL_8:.*]] = fir.absent !fir.class<!fir.type<_QMcaptured_optional_polymorphicTsometype>>
67+
! CHECK: %[[VAL_9:.*]] = arith.select %[[VAL_7]], %[[VAL_3]], %[[VAL_8]] : !fir.class<!fir.type<_QMcaptured_optional_polymorphicTsometype>>
68+
! CHECK: %[[VAL_10:.*]]:2 = hlfir.declare %[[VAL_9]] {fortran_attrs = #fir.var_attrs<optional, host_assoc>, {{.*}}Ex
69+
! CHECK: %[[VAL_11:.*]] = arith.constant 1 : i32
70+
! CHECK: %[[VAL_12:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_11]]
71+
! CHECK: %[[VAL_13:.*]] = fir.load %[[VAL_12]] : !fir.ref<!fir.class<!fir.array<?x!fir.type<_QMcaptured_optional_polymorphicTsometype>>>>
72+
! CHECK: %[[VAL_14:.*]] = arith.constant 0 : index
73+
! CHECK: %[[VAL_15:.*]]:3 = fir.box_dims %[[VAL_13]], %[[VAL_14]]
74+
! CHECK: %[[VAL_16:.*]] = fir.box_addr %[[VAL_13]]
75+
! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_16]] : (!fir.ref<!fir.array<?x!fir.type<_QMcaptured_optional_polymorphicTsometype>>>) -> i64
76+
! CHECK: %[[VAL_18:.*]] = arith.constant 0 : i64
77+
! CHECK: %[[VAL_19:.*]] = arith.cmpi ne, %[[VAL_17]], %[[VAL_18]] : i64
78+
! CHECK: %[[VAL_20:.*]] = fir.absent !fir.class<!fir.array<?x!fir.type<_QMcaptured_optional_polymorphicTsometype>>>
79+
! CHECK: %[[VAL_21:.*]] = arith.select %[[VAL_19]], %[[VAL_13]], %[[VAL_20]] : !fir.class<!fir.array<?x!fir.type<_QMcaptured_optional_polymorphicTsometype>>>
80+
! CHECK: %[[VAL_22:.*]] = fir.shift %[[VAL_15]]#0 : (index) -> !fir.shift<1>
81+
! CHECK: %[[VAL_23:.*]]:2 = hlfir.declare %[[VAL_21]](%[[VAL_22]]) {fortran_attrs = #fir.var_attrs<optional, host_assoc>, {{.*}}Ey

0 commit comments

Comments
 (0)