Skip to content

Commit 40e245a

Browse files
jeanPerierjeanPerier
authored
[flang] add support for procedure pointer assignment inside FORALL (#130114)
Very similar to object pointer assignment, the difference is the SSA types of the LHS (!fir.ref<!fir.boxproc<()->()>> and RHS (!fir.boxproc<()->()). The RHS must be saved as simple address, not descriptors (it is not possible to make CFI descriptor out of procedure entity).
1 parent 9c08e65 commit 40e245a

File tree

12 files changed

+567
-49
lines changed

12 files changed

+567
-49
lines changed

‎flang/include/flang/Optimizer/Builder/HLFIRTools.h

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -60,7 +60,7 @@ class Entity : public mlir::Value {
6060
bool isVariable() const { return !isValue(); }
6161
bool isMutableBox() const { return hlfir::isBoxAddressType(getType()); }
6262
bool isProcedurePointer() const {
63-
return fir::isBoxProcAddressType(getType());
63+
return hlfir::isFortranProcedurePointerType(getType());
6464
}
6565
bool isBoxAddressOrValue() const {
6666
return hlfir::isBoxAddressOrValueType(getType());

‎flang/include/flang/Optimizer/Builder/TemporaryStorage.h

Lines changed: 10 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -180,7 +180,7 @@ class AnyValueStack {
180180
/// dynamic type, bounds, and type parameters as the Nth variable that was
181181
/// pushed. It is implemented using runtime.
182182
/// Note that this is not meant to save POINTER or ALLOCATABLE descriptor
183-
/// addresses, use AnyDescriptorAddressStack instead.
183+
/// addresses, use AnyAddressStack instead.
184184
class AnyVariableStack {
185185
public:
186186
AnyVariableStack(mlir::Location loc, fir::FirOpBuilder &builder,
@@ -205,19 +205,21 @@ class AnyVariableStack {
205205
mlir::Value retValueBox;
206206
};
207207

208-
/// Data structure to stack descriptor addresses. It stores the descriptor
209-
/// addresses as int_ptr values under the hood.
210-
class AnyDescriptorAddressStack : public AnyValueStack {
208+
/// Data structure to stack simple addresses (C pointers). It can be used to
209+
/// store data base addresses, descriptor addresses, procedure addresses, and
210+
/// pointer procedure address. It stores the addresses as int_ptr values under
211+
/// the hood.
212+
class AnyAddressStack : public AnyValueStack {
211213
public:
212-
AnyDescriptorAddressStack(mlir::Location loc, fir::FirOpBuilder &builder,
213-
mlir::Type descriptorAddressType);
214+
AnyAddressStack(mlir::Location loc, fir::FirOpBuilder &builder,
215+
mlir::Type addressType);
214216

215217
void pushValue(mlir::Location loc, fir::FirOpBuilder &builder,
216218
mlir::Value value);
217219
mlir::Value fetch(mlir::Location loc, fir::FirOpBuilder &builder);
218220

219221
private:
220-
mlir::Type descriptorAddressType;
222+
mlir::Type addressType;
221223
};
222224

223225
class TemporaryStorage;
@@ -281,8 +283,7 @@ class TemporaryStorage {
281283

282284
private:
283285
std::variant<HomogeneousScalarStack, SimpleCopy, SSARegister, AnyValueStack,
284-
AnyVariableStack, AnyVectorSubscriptStack,
285-
AnyDescriptorAddressStack>
286+
AnyVariableStack, AnyVectorSubscriptStack, AnyAddressStack>
286287
impl;
287288
};
288289
} // namespace fir::factory

‎flang/include/flang/Optimizer/HLFIR/HLFIRDialect.h

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -82,6 +82,17 @@ inline bool isPolymorphicType(mlir::Type type) {
8282
return fir::isPolymorphicType(type);
8383
}
8484

85+
/// Is this the FIR type of a Fortran procedure pointer?
86+
inline bool isFortranProcedurePointerType(mlir::Type type) {
87+
return fir::isBoxProcAddressType(type);
88+
}
89+
90+
inline bool isFortranPointerObjectType(mlir::Type type) {
91+
auto boxTy =
92+
llvm::dyn_cast_or_null<fir::BaseBoxType>(fir::dyn_cast_ptrEleTy(type));
93+
return boxTy && boxTy.isPointer();
94+
}
95+
8596
/// Is this an SSA value type for the value of a Fortran procedure
8697
/// designator ?
8798
inline bool isFortranProcedureValue(mlir::Type type) {

‎flang/include/flang/Optimizer/HLFIR/HLFIROpBase.td

Lines changed: 3 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -91,10 +91,9 @@ def IsFortranVariablePred
9191
def AnyFortranVariable : Type<IsFortranVariablePred, "any HLFIR variable type">;
9292

9393

94-
def AnyFortranValue : TypeConstraint<Or<[AnyLogicalLike.predicate,
95-
AnyIntegerLike.predicate, AnyRealLike.predicate,
96-
AnyFirComplexLike.predicate,
97-
hlfir_ExprType.predicate]>, "any Fortran value type">;
94+
def IsFortranValuePred : CPred<"::hlfir::isFortranValueType($_self)">;
95+
def AnyFortranValue
96+
: TypeConstraint<IsFortranValuePred, "any Fortran value type">;
9897

9998

10099
def AnyFortranEntity : TypeConstraint<Or<[AnyFortranVariable.predicate,

‎flang/include/flang/Optimizer/HLFIR/HLFIROps.td

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1378,6 +1378,8 @@ def hlfir_RegionAssignOp : hlfir_Op<"region_assign", [hlfir_OrderedAssignmentTre
13781378
}
13791379
mlir::Region* getSubTreeRegion() { return nullptr; }
13801380
bool isPointerAssignment();
1381+
bool isPointerObjectAssignment();
1382+
bool isProcedurePointerAssignment();
13811383
}];
13821384

13831385
let hasCustomAssemblyFormat = 1;

‎flang/lib/Lower/Bridge.cpp

Lines changed: 18 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -4353,8 +4353,6 @@ class FirConverter : public Fortran::lower::AbstractConverter {
43534353
void genForallPointerAssignment(
43544354
mlir::Location loc, const Fortran::evaluate::Assignment &assign,
43554355
const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) {
4356-
if (Fortran::evaluate::IsProcedureDesignator(assign.rhs))
4357-
TODO(loc, "procedure pointer assignment inside FORALL");
43584356
std::optional<Fortran::evaluate::DynamicType> lhsType =
43594357
assign.lhs.GetType();
43604358
// Polymorphic pointer assignment is delegated to the runtime, and
@@ -4383,27 +4381,38 @@ class FirConverter : public Fortran::lower::AbstractConverter {
43834381
Fortran::lower::StatementContext lhsContext;
43844382
hlfir::Entity lhs = Fortran::lower::convertExprToHLFIR(
43854383
loc, *this, assign.lhs, localSymbols, lhsContext);
4386-
43874384
auto lhsYieldOp = builder->create<hlfir::YieldOp>(loc, lhs);
43884385
Fortran::lower::genCleanUpInRegionIfAny(
43894386
loc, *builder, lhsYieldOp.getCleanup(), lhsContext);
43904387

43914388
// Lower RHS in its own region.
43924389
builder->createBlock(&regionAssignOp.getRhsRegion());
43934390
Fortran::lower::StatementContext rhsContext;
4391+
mlir::Value rhs =
4392+
genForallPointerAssignmentRhs(loc, lhs, assign, rhsContext);
4393+
auto rhsYieldOp = builder->create<hlfir::YieldOp>(loc, rhs);
4394+
Fortran::lower::genCleanUpInRegionIfAny(
4395+
loc, *builder, rhsYieldOp.getCleanup(), rhsContext);
4396+
4397+
builder->setInsertionPointAfter(regionAssignOp);
4398+
}
4399+
4400+
mlir::Value
4401+
genForallPointerAssignmentRhs(mlir::Location loc, mlir::Value lhs,
4402+
const Fortran::evaluate::Assignment &assign,
4403+
Fortran::lower::StatementContext &rhsContext) {
4404+
if (Fortran::evaluate::IsProcedureDesignator(assign.rhs))
4405+
return fir::getBase(Fortran::lower::convertExprToAddress(
4406+
loc, *this, assign.rhs, localSymbols, rhsContext));
4407+
// Data target.
43944408
hlfir::Entity rhs = Fortran::lower::convertExprToHLFIR(
43954409
loc, *this, assign.rhs, localSymbols, rhsContext);
43964410
// Create pointer descriptor value from the RHS.
43974411
if (rhs.isMutableBox())
43984412
rhs = hlfir::Entity{builder->create<fir::LoadOp>(loc, rhs)};
43994413
auto lhsBoxType =
44004414
llvm::cast<fir::BaseBoxType>(fir::unwrapRefType(lhs.getType()));
4401-
mlir::Value newBox = hlfir::genVariableBox(loc, *builder, rhs, lhsBoxType);
4402-
auto rhsYieldOp = builder->create<hlfir::YieldOp>(loc, newBox);
4403-
Fortran::lower::genCleanUpInRegionIfAny(
4404-
loc, *builder, rhsYieldOp.getCleanup(), rhsContext);
4405-
4406-
builder->setInsertionPointAfter(regionAssignOp);
4415+
return hlfir::genVariableBox(loc, *builder, rhs, lhsBoxType);
44074416
}
44084417

44094418
// Create the 2 x newRank array with the bounds to be passed to the runtime as

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

Lines changed: 22 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -357,25 +357,33 @@ void fir::factory::AnyVectorSubscriptStack::destroy(
357357
}
358358

359359
//===----------------------------------------------------------------------===//
360-
// fir::factory::AnyDescriptorAddressStack implementation.
360+
// fir::factory::AnyAddressStack implementation.
361361
//===----------------------------------------------------------------------===//
362362

363-
fir::factory::AnyDescriptorAddressStack::AnyDescriptorAddressStack(
364-
mlir::Location loc, fir::FirOpBuilder &builder,
365-
mlir::Type descriptorAddressType)
363+
fir::factory::AnyAddressStack::AnyAddressStack(mlir::Location loc,
364+
fir::FirOpBuilder &builder,
365+
mlir::Type addressType)
366366
: AnyValueStack(loc, builder, builder.getIntPtrType()),
367-
descriptorAddressType{descriptorAddressType} {}
368-
369-
void fir::factory::AnyDescriptorAddressStack::pushValue(
370-
mlir::Location loc, fir::FirOpBuilder &builder, mlir::Value variable) {
371-
mlir::Value cast =
372-
builder.createConvert(loc, builder.getIntPtrType(), variable);
367+
addressType{addressType} {}
368+
369+
void fir::factory::AnyAddressStack::pushValue(mlir::Location loc,
370+
fir::FirOpBuilder &builder,
371+
mlir::Value variable) {
372+
mlir::Value cast = variable;
373+
if (auto boxProcType = llvm::dyn_cast<fir::BoxProcType>(variable.getType())) {
374+
cast =
375+
builder.create<fir::BoxAddrOp>(loc, boxProcType.getEleTy(), variable);
376+
}
377+
cast = builder.createConvert(loc, builder.getIntPtrType(), cast);
373378
static_cast<AnyValueStack *>(this)->pushValue(loc, builder, cast);
374379
}
375380

376-
mlir::Value
377-
fir::factory::AnyDescriptorAddressStack::fetch(mlir::Location loc,
378-
fir::FirOpBuilder &builder) {
381+
mlir::Value fir::factory::AnyAddressStack::fetch(mlir::Location loc,
382+
fir::FirOpBuilder &builder) {
379383
mlir::Value addr = static_cast<AnyValueStack *>(this)->fetch(loc, builder);
380-
return builder.createConvert(loc, descriptorAddressType, addr);
384+
if (auto boxProcType = llvm::dyn_cast<fir::BoxProcType>(addressType)) {
385+
mlir::Value cast = builder.createConvert(loc, boxProcType.getEleTy(), addr);
386+
return builder.create<fir::EmboxProcOp>(loc, boxProcType, cast);
387+
}
388+
return builder.createConvert(loc, addressType, addr);
381389
}

‎flang/lib/Optimizer/HLFIR/IR/HLFIROps.cpp

Lines changed: 23 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -1891,18 +1891,33 @@ llvm::LogicalResult hlfir::RegionAssignOp::verify() {
18911891
return mlir::success();
18921892
}
18931893

1894-
bool hlfir::RegionAssignOp::isPointerAssignment() {
1894+
static mlir::Type
1895+
getNonVectorSubscriptedLhsType(hlfir::RegionAssignOp regionAssign) {
1896+
hlfir::YieldOp yieldOp = mlir::dyn_cast_or_null<hlfir::YieldOp>(
1897+
getTerminator(regionAssign.getLhsRegion()));
1898+
return yieldOp ? yieldOp.getEntity().getType() : mlir::Type{};
1899+
}
1900+
1901+
bool hlfir::RegionAssignOp::isPointerObjectAssignment() {
18951902
if (!getUserDefinedAssignment().empty())
18961903
return false;
1897-
hlfir::YieldOp yieldOp =
1898-
mlir::dyn_cast_or_null<hlfir::YieldOp>(getTerminator(getLhsRegion()));
1899-
if (!yieldOp)
1904+
mlir::Type lhsType = getNonVectorSubscriptedLhsType(*this);
1905+
return lhsType && hlfir::isFortranPointerObjectType(lhsType);
1906+
}
1907+
1908+
bool hlfir::RegionAssignOp::isProcedurePointerAssignment() {
1909+
if (!getUserDefinedAssignment().empty())
19001910
return false;
1901-
mlir::Type lhsType = yieldOp.getEntity().getType();
1902-
if (!hlfir::isBoxAddressType(lhsType))
1911+
mlir::Type lhsType = getNonVectorSubscriptedLhsType(*this);
1912+
return lhsType && hlfir::isFortranProcedurePointerType(lhsType);
1913+
}
1914+
1915+
bool hlfir::RegionAssignOp::isPointerAssignment() {
1916+
if (!getUserDefinedAssignment().empty())
19031917
return false;
1904-
auto baseBoxType = llvm::cast<fir::BaseBoxType>(fir::unwrapRefType(lhsType));
1905-
return baseBoxType.isPointer();
1918+
mlir::Type lhsType = getNonVectorSubscriptedLhsType(*this);
1919+
return lhsType && (hlfir::isFortranPointerObjectType(lhsType) ||
1920+
hlfir::isFortranProcedurePointerType(lhsType));
19061921
}
19071922

19081923
//===----------------------------------------------------------------------===//

‎flang/lib/Optimizer/HLFIR/Transforms/LowerHLFIROrderedAssignments.cpp

Lines changed: 6 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1277,11 +1277,13 @@ void OrderedAssignmentRewriter::saveNonVectorSubscriptedAddress(
12771277
[&] { temp = insertSavedEntity(region, fir::factory::SSARegister{}); });
12781278
else
12791279
doBeforeLoopNest([&] {
1280-
if (var.isMutableBox())
1281-
temp =
1282-
insertSavedEntity(region, fir::factory::AnyDescriptorAddressStack{
1283-
loc, builder, var.getType()});
1280+
if (var.isMutableBox() || var.isProcedure() || var.isProcedurePointer())
1281+
// Store single C pointer to entity.
1282+
temp = insertSavedEntity(
1283+
region, fir::factory::AnyAddressStack{loc, builder, var.getType()});
12841284
else
1285+
// Store the base address and dynamic shape/length/type information
1286+
// as descriptor.
12851287
temp = insertSavedEntity(region, fir::factory::AnyVariableStack{
12861288
loc, builder, var.getType()});
12871289
});

0 commit comments

Comments
 (0)