Skip to content

Commit 4b1846f

Browse files
jeanPerierjeanPerier
committed
Fix bug from patch on the callee side
Lowering hit and assert with the previous patch because it is not meant to manipulate scalars characters as fir.box. Add the code to open the fir.box of BIND(C) characters on the callee side, taking care of dealing with the case where the fir.box is optional and cannot be addressed unconditionally.
1 parent 8df115b commit 4b1846f

File tree

3 files changed

+78
-14
lines changed

3 files changed

+78
-14
lines changed

‎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: 28 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -1,18 +1,41 @@
11
! Test that assumed length character scalars and explicit shape arrays are passed via
22
! CFI descriptor (fir.box) in BIND(C) procedures. They are passed only by address
33
! and length in non BIND(C) procedures. See Fortran 2018 standard 18.3.6 point 2(5).
4-
! RUN: bbc -emit-hlfir -o - %s 2>&1 | FileCheck %s
4+
! RUN: bbc -hlfir -emit-fir -o - %s 2>&1 | FileCheck %s
55

6-
! CHECK: func.func @foo(
6+
module bindcchar
7+
contains
8+
! CHECK-LABEL: func.func @bindc(
79
! CHECK-SAME: %{{[^:]*}}: !fir.box<!fir.char<1,?>>
810
! CHECK-SAME: %{{[^:]*}}: !fir.box<!fir.array<100x!fir.char<1,?>>>
9-
subroutine foo(c1, c3) bind(c)
10-
character(*) :: c1, c3(100)
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)
1122
end subroutine
1223

13-
! CHECK: func.func @_QPnot_bindc(
24+
! CHECK-LABEL: func.func @_QMbindccharPnot_bindc(
1425
! CHECK-SAME: %{{[^:]*}}: !fir.boxchar<1>
1526
! CHECK-SAME: %{{[^:]*}}: !fir.boxchar<1>
1627
subroutine not_bindc(c1, c3)
1728
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)
1840
end subroutine
41+
end module

0 commit comments

Comments
 (0)