Skip to content

Commit 5b6f3fc

Browse files
jeanPerierjeanPerier
authored
[flang] Lower BIND(C) assumed length to CFI descriptor (#65950)
Outside of BIND(C), assumed length character scalar and explicit shape are passed by address + an extra length argument (fir.boxchar in FIR). The standard mandates that they be passed via CFI descriptor in BIND(C) interface (fir.box in FIR). This patch fix the handling for this case.
1 parent 7cf20f1 commit 5b6f3fc

File tree

4 files changed

+97
-12
lines changed

4 files changed

+97
-12
lines changed

‎flang/lib/Lower/CallInterface.cpp

Lines changed: 6 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -702,7 +702,7 @@ class Fortran::lower::CallInterfaceImpl {
702702
[&](const Fortran::evaluate::characteristics::DummyDataObject
703703
&dummy) {
704704
const auto &entity = getDataObjectEntity(std::get<1>(pair));
705-
if (dummy.CanBePassedViaImplicitInterface())
705+
if (!isBindC && dummy.CanBePassedViaImplicitInterface())
706706
handleImplicitDummy(&argCharacteristics, dummy, entity);
707707
else
708708
handleExplicitDummy(&argCharacteristics, dummy, entity,
@@ -871,7 +871,8 @@ class Fortran::lower::CallInterfaceImpl {
871871

872872
// Define when an explicit argument must be passed in a fir.box.
873873
bool dummyRequiresBox(
874-
const Fortran::evaluate::characteristics::DummyDataObject &obj) {
874+
const Fortran::evaluate::characteristics::DummyDataObject &obj,
875+
bool isBindC) {
875876
using ShapeAttr = Fortran::evaluate::characteristics::TypeAndShape::Attr;
876877
using ShapeAttrs = Fortran::evaluate::characteristics::TypeAndShape::Attrs;
877878
constexpr ShapeAttrs shapeRequiringBox = {
@@ -888,6 +889,8 @@ class Fortran::lower::CallInterfaceImpl {
888889
if (const Fortran::semantics::Scope *scope = derived->scope())
889890
// Need to pass length type parameters in fir.box if any.
890891
return scope->IsDerivedTypeWithLengthParameter();
892+
if (isBindC && obj.type.type().IsAssumedLengthCharacter())
893+
return true; // Fortran 2018 18.3.6 point 2 (5)
891894
return false;
892895
}
893896

@@ -973,7 +976,7 @@ class Fortran::lower::CallInterfaceImpl {
973976
addFirOperand(boxRefType, nextPassedArgPosition(), Property::MutableBox,
974977
attrs);
975978
addPassedArg(PassEntityBy::MutableBox, entity, characteristics);
976-
} else if (dummyRequiresBox(obj)) {
979+
} else if (dummyRequiresBox(obj, isBindC)) {
977980
// Pass as fir.box or fir.class
978981
if (isValueAttr)
979982
TODO(loc, "assumed shape dummy argument with VALUE attribute");

‎flang/lib/Lower/ConvertVariable.cpp

Lines changed: 50 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1275,12 +1275,14 @@ static void instantiateCommon(Fortran::lower::AbstractConverter &converter,
12751275

12761276
/// Helper to decide if a dummy argument must be tracked in an BoxValue.
12771277
static bool lowerToBoxValue(const Fortran::semantics::Symbol &sym,
1278-
mlir::Value dummyArg) {
1278+
mlir::Value dummyArg,
1279+
Fortran::lower::AbstractConverter &converter) {
12791280
// Only dummy arguments coming as fir.box can be tracked in an BoxValue.
12801281
if (!dummyArg || !dummyArg.getType().isa<fir::BaseBoxType>())
12811282
return false;
12821283
// Non contiguous arrays must be tracked in an BoxValue.
1283-
if (sym.Rank() > 0 && !sym.attrs().test(Fortran::semantics::Attr::CONTIGUOUS))
1284+
if (sym.Rank() > 0 && !Fortran::evaluate::IsSimplyContiguous(
1285+
sym, converter.getFoldingContext()))
12841286
return true;
12851287
// Assumed rank and optional fir.box cannot yet be read while lowering the
12861288
// specifications.
@@ -1713,16 +1715,60 @@ void Fortran::lower::mapSymbolAttributes(
17131715

17141716
if (isDummy) {
17151717
mlir::Value dummyArg = symMap.lookupSymbol(sym).getAddr();
1716-
if (lowerToBoxValue(sym, dummyArg)) {
1718+
if (lowerToBoxValue(sym, dummyArg, converter)) {
17171719
llvm::SmallVector<mlir::Value> lbounds;
17181720
llvm::SmallVector<mlir::Value> explicitExtents;
17191721
llvm::SmallVector<mlir::Value> explicitParams;
17201722
// Lower lower bounds, explicit type parameters and explicit
17211723
// extents if any.
1722-
if (ba.isChar())
1724+
if (ba.isChar()) {
17231725
if (mlir::Value len =
17241726
lowerExplicitCharLen(converter, loc, ba, symMap, stmtCtx))
17251727
explicitParams.push_back(len);
1728+
if (sym.Rank() == 0) {
1729+
// Do not keep scalar characters as fir.box (even when optional).
1730+
// Lowering and FIR is not meant to deal with scalar characters as
1731+
// fir.box outside of calls.
1732+
auto boxTy = dummyArg.getType().dyn_cast<fir::BaseBoxType>();
1733+
mlir::Type refTy = builder.getRefType(boxTy.getEleTy());
1734+
mlir::Type lenType = builder.getCharacterLengthType();
1735+
mlir::Value addr, len;
1736+
if (Fortran::semantics::IsOptional(sym)) {
1737+
auto isPresent = builder.create<fir::IsPresentOp>(
1738+
loc, builder.getI1Type(), dummyArg);
1739+
auto addrAndLen =
1740+
builder
1741+
.genIfOp(loc, {refTy, lenType}, isPresent,
1742+
/*withElseRegion=*/true)
1743+
.genThen([&]() {
1744+
mlir::Value readAddr =
1745+
builder.create<fir::BoxAddrOp>(loc, refTy, dummyArg);
1746+
mlir::Value readLength =
1747+
charHelp.readLengthFromBox(dummyArg);
1748+
builder.create<fir::ResultOp>(
1749+
loc, mlir::ValueRange{readAddr, readLength});
1750+
})
1751+
.genElse([&] {
1752+
mlir::Value readAddr = builder.genAbsentOp(loc, refTy);
1753+
mlir::Value readLength =
1754+
fir::factory::createZeroValue(builder, loc, lenType);
1755+
builder.create<fir::ResultOp>(
1756+
loc, mlir::ValueRange{readAddr, readLength});
1757+
})
1758+
.getResults();
1759+
addr = addrAndLen[0];
1760+
len = addrAndLen[1];
1761+
} else {
1762+
addr = builder.create<fir::BoxAddrOp>(loc, refTy, dummyArg);
1763+
len = charHelp.readLengthFromBox(dummyArg);
1764+
}
1765+
if (!explicitParams.empty())
1766+
len = explicitParams[0];
1767+
::genDeclareSymbol(converter, symMap, sym, addr, len, /*extents=*/{},
1768+
/*lbounds=*/{}, replace);
1769+
return;
1770+
}
1771+
}
17261772
// TODO: derived type length parameters.
17271773
lowerExplicitLowerBounds(converter, loc, ba, lbounds, symMap, stmtCtx);
17281774
lowerExplicitExtents(converter, loc, ba, lbounds, explicitExtents, symMap,

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

Lines changed: 0 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -214,11 +214,6 @@ bool fir::BoxValue::verify() const {
214214
return false;
215215
if (!lbounds.empty() && lbounds.size() != rank())
216216
return false;
217-
// Explicit extents are here to cover cases where an explicit-shape dummy
218-
// argument comes as a fir.box. This can only happen with derived types and
219-
// unlimited polymorphic.
220-
if (!extents.empty() && !(isDerived() || isUnlimitedPolymorphic()))
221-
return false;
222217
if (!extents.empty() && extents.size() != rank())
223218
return false;
224219
if (isCharacter() && explicitParams.size() > 1)

‎flang/test/Lower/HLFIR/bindc-assumed-length.f90

Lines changed: 41 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,41 @@
1+
! Test that assumed length character scalars and explicit shape arrays are passed via
2+
! CFI descriptor (fir.box) in BIND(C) procedures. They are passed only by address
3+
! and length in non BIND(C) procedures. See Fortran 2018 standard 18.3.6 point 2(5).
4+
! RUN: bbc -hlfir -emit-fir -o - %s 2>&1 | FileCheck %s
5+
6+
module bindcchar
7+
contains
8+
! CHECK-LABEL: func.func @bindc(
9+
! CHECK-SAME: %{{[^:]*}}: !fir.box<!fir.char<1,?>>
10+
! CHECK-SAME: %{{[^:]*}}: !fir.box<!fir.array<100x!fir.char<1,?>>>
11+
subroutine bindc(c1, c3) bind(c)
12+
character(*) :: c1, c3(100)
13+
print *, c1(1:3), c3(5)(1:3)
14+
end subroutine
15+
16+
! CHECK-LABEL: func.func @bindc_optional(
17+
! CHECK-SAME: %{{[^:]*}}: !fir.box<!fir.char<1,?>>
18+
! CHECK-SAME: %{{[^:]*}}: !fir.box<!fir.array<100x!fir.char<1,?>>>
19+
subroutine bindc_optional(c1, c3) bind(c)
20+
character(*), optional :: c1, c3(100)
21+
print *, c1(1:3), c3(5)(1:3)
22+
end subroutine
23+
24+
! CHECK-LABEL: func.func @_QMbindccharPnot_bindc(
25+
! CHECK-SAME: %{{[^:]*}}: !fir.boxchar<1>
26+
! CHECK-SAME: %{{[^:]*}}: !fir.boxchar<1>
27+
subroutine not_bindc(c1, c3)
28+
character(*) :: c1, c3(100)
29+
call bindc(c1, c3)
30+
call bindc_optional(c1, c3)
31+
end subroutine
32+
33+
! CHECK-LABEL: func.func @_QMbindccharPnot_bindc_optional(
34+
! CHECK-SAME: %{{[^:]*}}: !fir.boxchar<1>
35+
! CHECK-SAME: %{{[^:]*}}: !fir.boxchar<1>
36+
subroutine not_bindc_optional(c1, c3)
37+
character(*), optional :: c1, c3(100)
38+
call bindc(c1, c3)
39+
call bindc_optional(c1, c3)
40+
end subroutine
41+
end module

0 commit comments

Comments
 (0)