caio/clang-p2996
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

[flang] add support for procedure pointer assignment inside FORALL (#130114)

Browse Source 
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).
This commit is contained in:
jeanPerier
2025-03-07 10:28:02 +01:00
committed by GitHub
parent 9c08e650cd
commit 40e245a9aa
12 changed files with 567 additions and 49 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
flang/include/flang/Optimizer/Builder/HLFIRTools.h
View File

@@ -60,7 +60,7 @@ public:
bool isVariable() const { return !isValue(); }
bool isMutableBox() const { return hlfir::isBoxAddressType(getType()); }
bool isProcedurePointer() const {
return fir::isBoxProcAddressType(getType());
return hlfir::isFortranProcedurePointerType(getType());
}
bool isBoxAddressOrValue() const {
return hlfir::isBoxAddressOrValueType(getType());

19
flang/include/flang/Optimizer/Builder/TemporaryStorage.h
View File

@@ -180,7 +180,7 @@ private:
/// dynamic type, bounds, and type parameters as the Nth variable that was
/// pushed. It is implemented using runtime.
/// Note that this is not meant to save POINTER or ALLOCATABLE descriptor
/// addresses, use AnyDescriptorAddressStack instead.
/// addresses, use AnyAddressStack instead.
class AnyVariableStack {
public:
AnyVariableStack(mlir::Location loc, fir::FirOpBuilder &builder,
@@ -205,19 +205,21 @@ private:
mlir::Value retValueBox;
};
/// Data structure to stack descriptor addresses. It stores the descriptor
/// addresses as int_ptr values under the hood.
class AnyDescriptorAddressStack : public AnyValueStack {
/// Data structure to stack simple addresses (C pointers). It can be used to
/// store data base addresses, descriptor addresses, procedure addresses, and
/// pointer procedure address. It stores the addresses as int_ptr values under
/// the hood.
class AnyAddressStack : public AnyValueStack {
public:
AnyDescriptorAddressStack(mlir::Location loc, fir::FirOpBuilder &builder,
mlir::Type descriptorAddressType);
AnyAddressStack(mlir::Location loc, fir::FirOpBuilder &builder,
mlir::Type addressType);
void pushValue(mlir::Location loc, fir::FirOpBuilder &builder,
mlir::Value value);
mlir::Value fetch(mlir::Location loc, fir::FirOpBuilder &builder);
private:
mlir::Type descriptorAddressType;
mlir::Type addressType;
};
class TemporaryStorage;
@@ -281,8 +283,7 @@ public:
private:
std::variant<HomogeneousScalarStack, SimpleCopy, SSARegister, AnyValueStack,
AnyVariableStack, AnyVectorSubscriptStack,
AnyDescriptorAddressStack>
AnyVariableStack, AnyVectorSubscriptStack, AnyAddressStack>
impl;
};
} // namespace fir::factory

11
flang/include/flang/Optimizer/HLFIR/HLFIRDialect.h
View File

@@ -82,6 +82,17 @@ inline bool isPolymorphicType(mlir::Type type) {
return fir::isPolymorphicType(type);
}
/// Is this the FIR type of a Fortran procedure pointer?
inline bool isFortranProcedurePointerType(mlir::Type type) {
return fir::isBoxProcAddressType(type);
}
inline bool isFortranPointerObjectType(mlir::Type type) {
auto boxTy =
llvm::dyn_cast_or_null<fir::BaseBoxType>(fir::dyn_cast_ptrEleTy(type));
return boxTy && boxTy.isPointer();
}
/// Is this an SSA value type for the value of a Fortran procedure
/// designator ?
inline bool isFortranProcedureValue(mlir::Type type) {

7
flang/include/flang/Optimizer/HLFIR/HLFIROpBase.td
View File

@@ -91,10 +91,9 @@ def IsFortranVariablePred
def AnyFortranVariable : Type<IsFortranVariablePred, "any HLFIR variable type">;
def AnyFortranValue : TypeConstraint<Or<[AnyLogicalLike.predicate,
AnyIntegerLike.predicate, AnyRealLike.predicate,
AnyFirComplexLike.predicate,
hlfir_ExprType.predicate]>, "any Fortran value type">;
def IsFortranValuePred : CPred<"::hlfir::isFortranValueType($_self)">;
def AnyFortranValue
: TypeConstraint<IsFortranValuePred, "any Fortran value type">;
def AnyFortranEntity : TypeConstraint<Or<[AnyFortranVariable.predicate,

2
flang/include/flang/Optimizer/HLFIR/HLFIROps.td
View File

@@ -1378,6 +1378,8 @@ def hlfir_RegionAssignOp : hlfir_Op<"region_assign", [hlfir_OrderedAssignmentTre
}
mlir::Region* getSubTreeRegion() { return nullptr; }
bool isPointerAssignment();
bool isPointerObjectAssignment();
bool isProcedurePointerAssignment();
}];
let hasCustomAssemblyFormat = 1;

27
flang/lib/Lower/Bridge.cpp
View File

@@ -4353,8 +4353,6 @@ private:
void genForallPointerAssignment(
mlir::Location loc, const Fortran::evaluate::Assignment &assign,
const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) {
if (Fortran::evaluate::IsProcedureDesignator(assign.rhs))
TODO(loc, "procedure pointer assignment inside FORALL");
std::optional<Fortran::evaluate::DynamicType> lhsType =
assign.lhs.GetType();
// Polymorphic pointer assignment is delegated to the runtime, and
@@ -4383,7 +4381,6 @@ private:
Fortran::lower::StatementContext lhsContext;
hlfir::Entity lhs = Fortran::lower::convertExprToHLFIR(
loc, *this, assign.lhs, localSymbols, lhsContext);
auto lhsYieldOp = builder->create<hlfir::YieldOp>(loc, lhs);
Fortran::lower::genCleanUpInRegionIfAny(
loc, *builder, lhsYieldOp.getCleanup(), lhsContext);
@@ -4391,6 +4388,23 @@ private:
// Lower RHS in its own region.
builder->createBlock(&regionAssignOp.getRhsRegion());
Fortran::lower::StatementContext rhsContext;
mlir::Value rhs =
genForallPointerAssignmentRhs(loc, lhs, assign, rhsContext);
auto rhsYieldOp = builder->create<hlfir::YieldOp>(loc, rhs);
Fortran::lower::genCleanUpInRegionIfAny(
loc, *builder, rhsYieldOp.getCleanup(), rhsContext);
builder->setInsertionPointAfter(regionAssignOp);
}
mlir::Value
genForallPointerAssignmentRhs(mlir::Location loc, mlir::Value lhs,
const Fortran::evaluate::Assignment &assign,
Fortran::lower::StatementContext &rhsContext) {
if (Fortran::evaluate::IsProcedureDesignator(assign.rhs))
return fir::getBase(Fortran::lower::convertExprToAddress(
loc, *this, assign.rhs, localSymbols, rhsContext));
// Data target.
hlfir::Entity rhs = Fortran::lower::convertExprToHLFIR(
loc, *this, assign.rhs, localSymbols, rhsContext);
// Create pointer descriptor value from the RHS.
@@ -4398,12 +4412,7 @@ private:
rhs = hlfir::Entity{builder->create<fir::LoadOp>(loc, rhs)};
auto lhsBoxType =
llvm::cast<fir::BaseBoxType>(fir::unwrapRefType(lhs.getType()));
mlir::Value newBox = hlfir::genVariableBox(loc, *builder, rhs, lhsBoxType);
auto rhsYieldOp = builder->create<hlfir::YieldOp>(loc, newBox);
Fortran::lower::genCleanUpInRegionIfAny(
loc, *builder, rhsYieldOp.getCleanup(), rhsContext);
builder->setInsertionPointAfter(regionAssignOp);
return hlfir::genVariableBox(loc, *builder, rhs, lhsBoxType);
}
// Create the 2 x newRank array with the bounds to be passed to the runtime as

34
flang/lib/Optimizer/Builder/TemporaryStorage.cpp
View File

@@ -357,25 +357,33 @@ void fir::factory::AnyVectorSubscriptStack::destroy(
}
//===----------------------------------------------------------------------===//
// fir::factory::AnyDescriptorAddressStack implementation.
// fir::factory::AnyAddressStack implementation.
//===----------------------------------------------------------------------===//
fir::factory::AnyDescriptorAddressStack::AnyDescriptorAddressStack(
mlir::Location loc, fir::FirOpBuilder &builder,
mlir::Type descriptorAddressType)
fir::factory::AnyAddressStack::AnyAddressStack(mlir::Location loc,
fir::FirOpBuilder &builder,
mlir::Type addressType)
: AnyValueStack(loc, builder, builder.getIntPtrType()),
descriptorAddressType{descriptorAddressType} {}
addressType{addressType} {}
void fir::factory::AnyDescriptorAddressStack::pushValue(
mlir::Location loc, fir::FirOpBuilder &builder, mlir::Value variable) {
mlir::Value cast =
builder.createConvert(loc, builder.getIntPtrType(), variable);
void fir::factory::AnyAddressStack::pushValue(mlir::Location loc,
fir::FirOpBuilder &builder,
mlir::Value variable) {
mlir::Value cast = variable;
if (auto boxProcType = llvm::dyn_cast<fir::BoxProcType>(variable.getType())) {
cast =
builder.create<fir::BoxAddrOp>(loc, boxProcType.getEleTy(), variable);
}
cast = builder.createConvert(loc, builder.getIntPtrType(), cast);
static_cast<AnyValueStack *>(this)->pushValue(loc, builder, cast);
}
mlir::Value
fir::factory::AnyDescriptorAddressStack::fetch(mlir::Location loc,
fir::FirOpBuilder &builder) {
mlir::Value fir::factory::AnyAddressStack::fetch(mlir::Location loc,
fir::FirOpBuilder &builder) {
mlir::Value addr = static_cast<AnyValueStack *>(this)->fetch(loc, builder);
return builder.createConvert(loc, descriptorAddressType, addr);
if (auto boxProcType = llvm::dyn_cast<fir::BoxProcType>(addressType)) {
mlir::Value cast = builder.createConvert(loc, boxProcType.getEleTy(), addr);
return builder.create<fir::EmboxProcOp>(loc, boxProcType, cast);
}
return builder.createConvert(loc, addressType, addr);
}

33
flang/lib/Optimizer/HLFIR/IR/HLFIROps.cpp
View File

@@ -1891,18 +1891,33 @@ llvm::LogicalResult hlfir::RegionAssignOp::verify() {
return mlir::success();
}
static mlir::Type
getNonVectorSubscriptedLhsType(hlfir::RegionAssignOp regionAssign) {
hlfir::YieldOp yieldOp = mlir::dyn_cast_or_null<hlfir::YieldOp>(
getTerminator(regionAssign.getLhsRegion()));
return yieldOp ? yieldOp.getEntity().getType() : mlir::Type{};
}
bool hlfir::RegionAssignOp::isPointerObjectAssignment() {
if (!getUserDefinedAssignment().empty())
return false;
mlir::Type lhsType = getNonVectorSubscriptedLhsType(*this);
return lhsType && hlfir::isFortranPointerObjectType(lhsType);
}
bool hlfir::RegionAssignOp::isProcedurePointerAssignment() {
if (!getUserDefinedAssignment().empty())
return false;
mlir::Type lhsType = getNonVectorSubscriptedLhsType(*this);
return lhsType && hlfir::isFortranProcedurePointerType(lhsType);
}
bool hlfir::RegionAssignOp::isPointerAssignment() {
if (!getUserDefinedAssignment().empty())
return false;
hlfir::YieldOp yieldOp =
mlir::dyn_cast_or_null<hlfir::YieldOp>(getTerminator(getLhsRegion()));
if (!yieldOp)
return false;
mlir::Type lhsType = yieldOp.getEntity().getType();
if (!hlfir::isBoxAddressType(lhsType))
return false;
auto baseBoxType = llvm::cast<fir::BaseBoxType>(fir::unwrapRefType(lhsType));
return baseBoxType.isPointer();
mlir::Type lhsType = getNonVectorSubscriptedLhsType(*this);
return lhsType && (hlfir::isFortranPointerObjectType(lhsType) ||
hlfir::isFortranProcedurePointerType(lhsType));
}
//===----------------------------------------------------------------------===//

10
flang/lib/Optimizer/HLFIR/Transforms/LowerHLFIROrderedAssignments.cpp
View File

@@ -1277,11 +1277,13 @@ void OrderedAssignmentRewriter::saveNonVectorSubscriptedAddress(
[&] { temp = insertSavedEntity(region, fir::factory::SSARegister{}); });
else
doBeforeLoopNest([&] {
if (var.isMutableBox())
temp =
insertSavedEntity(region, fir::factory::AnyDescriptorAddressStack{
loc, builder, var.getType()});
if (var.isMutableBox() || var.isProcedure() || var.isProcedurePointer())
// Store single C pointer to entity.
temp = insertSavedEntity(
region, fir::factory::AnyAddressStack{loc, builder, var.getType()});
else
// Store the base address and dynamic shape/length/type information
// as descriptor.
temp = insertSavedEntity(region, fir::factory::AnyVariableStack{
loc, builder, var.getType()});
});

222
flang/test/HLFIR/order_assignments/forall-proc-pointer-assignment-codegen.fir Normal file
View File

@@ -0,0 +1,222 @@
// Test code generation of hlfir.region_assign representing procedure pointer
// assignments inside FORALL.
// RUN: fir-opt %s --lower-hlfir-ordered-assignments | FileCheck %s
!t=!fir.type<t{p:!fir.boxproc<() -> i32>}>
func.func @test_no_conflict(%arg0: !fir.ref<!fir.array<10x!t>> {fir.bindc_name = "x"}) {
%c10_i64 = arith.constant 10 : i64
%c1_i64 = arith.constant 1 : i64
%c10 = arith.constant 10 : index
%0 = fir.dummy_scope : !fir.dscope
%1 = fir.shape %c10 : (index) -> !fir.shape<1>
%2:2 = hlfir.declare %arg0(%1) dummy_scope %0 {uniq_name = "x"} : (!fir.ref<!fir.array<10x!t>>, !fir.shape<1>, !fir.dscope) -> (!fir.ref<!fir.array<10x!t>>, !fir.ref<!fir.array<10x!t>>)
hlfir.forall lb {
hlfir.yield %c1_i64 : i64
} ub {
hlfir.yield %c10_i64 : i64
} (%arg1: i64) {
hlfir.region_assign {
%3 = fir.address_of(@f1) : () -> i32
%4 = fir.emboxproc %3 : (() -> i32) -> !fir.boxproc<() -> ()>
hlfir.yield %4 : !fir.boxproc<() -> ()>
} to {
%3 = hlfir.designate %2#0 (%arg1) : (!fir.ref<!fir.array<10x!t>>, i64) -> !fir.ref<!t>
%4 = hlfir.designate %3{"p"} {fortran_attrs = #fir.var_attrs<pointer>} : (!fir.ref<!t>) -> !fir.ref<!fir.boxproc<() -> i32>>
hlfir.yield %4 : !fir.ref<!fir.boxproc<() -> i32>>
}
}
return
}
// CHECK-LABEL: func.func @test_no_conflict(
// CHECK: %[[VAL_1:.*]] = arith.constant 10 : i64
// CHECK: %[[VAL_2:.*]] = arith.constant 1 : i64
// CHECK: %[[VAL_3:.*]] = arith.constant 10 : index
// CHECK: %[[VAL_4:.*]] = fir.dummy_scope : !fir.dscope
// CHECK: %[[VAL_5:.*]] = fir.shape %[[VAL_3]] : (index) -> !fir.shape<1>
// CHECK: %[[VAL_6:.*]]:2 = hlfir.declare{{.*}}"x"
// CHECK: %[[VAL_7:.*]] = fir.convert %[[VAL_2]] : (i64) -> index
// CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_1]] : (i64) -> index
// CHECK: %[[VAL_9:.*]] = arith.constant 1 : index
// CHECK: fir.do_loop %[[VAL_10:.*]] = %[[VAL_7]] to %[[VAL_8]] step %[[VAL_9]] {
// CHECK: %[[VAL_11:.*]] = fir.convert %[[VAL_10]] : (index) -> i64
// CHECK: %[[VAL_12:.*]] = hlfir.designate %[[VAL_6]]#0 (%[[VAL_11]]) : (!fir.ref<!fir.array<10x!fir.type<t{p:!fir.boxproc<() -> i32>}>>>, i64) -> !fir.ref<!fir.type<t{p:!fir.boxproc<() -> i32>}>>
// CHECK: %[[VAL_13:.*]] = hlfir.designate %[[VAL_12]]{"p"} {fortran_attrs = #fir.var_attrs<pointer>} : (!fir.ref<!fir.type<t{p:!fir.boxproc<() -> i32>}>>) -> !fir.ref<!fir.boxproc<() -> i32>>
// CHECK: %[[VAL_14:.*]] = fir.address_of(@f1) : () -> i32
// CHECK: %[[VAL_15:.*]] = fir.emboxproc %[[VAL_14]] : (() -> i32) -> !fir.boxproc<() -> ()>
// CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_15]] : (!fir.boxproc<() -> ()>) -> !fir.boxproc<() -> i32>
// CHECK: fir.store %[[VAL_16]] to %[[VAL_13]] : !fir.ref<!fir.boxproc<() -> i32>>
// CHECK: }
// CHECK: return
// CHECK: }
func.func @test_need_to_save_rhs(%arg0: !fir.ref<!fir.array<10x!t>> {fir.bindc_name = "x"}) {
%c10_i64 = arith.constant 10 : i64
%c1_i64 = arith.constant 1 : i64
%c10 = arith.constant 10 : index
%0 = fir.dummy_scope : !fir.dscope
%1 = fir.shape %c10 : (index) -> !fir.shape<1>
%2:2 = hlfir.declare %arg0(%1) dummy_scope %0 {uniq_name = "x"} : (!fir.ref<!fir.array<10x!t>>, !fir.shape<1>, !fir.dscope) -> (!fir.ref<!fir.array<10x!t>>, !fir.ref<!fir.array<10x!t>>)
hlfir.forall lb {
hlfir.yield %c1_i64 : i64
} ub {
hlfir.yield %c10_i64 : i64
} (%arg1: i64) {
hlfir.region_assign {
%3 = hlfir.designate %2#0 (%c10) : (!fir.ref<!fir.array<10x!t>>, index) -> !fir.ref<!t>
%4 = hlfir.designate %3{"p"} {fortran_attrs = #fir.var_attrs<pointer>} : (!fir.ref<!t>) -> !fir.ref<!fir.boxproc<() -> i32>>
%5 = fir.load %4 : !fir.ref<!fir.boxproc<() -> i32>>
hlfir.yield %5 : !fir.boxproc<() -> i32>
} to {
%3 = hlfir.designate %2#0 (%arg1) : (!fir.ref<!fir.array<10x!t>>, i64) -> !fir.ref<!t>
%4 = hlfir.designate %3{"p"} {fortran_attrs = #fir.var_attrs<pointer>} : (!fir.ref<!t>) -> !fir.ref<!fir.boxproc<() -> i32>>
hlfir.yield %4 : !fir.ref<!fir.boxproc<() -> i32>>
}
}
return
}
// CHECK-LABEL: func.func @test_need_to_save_rhs(
// CHECK: %[[VAL_1:.*]] = fir.alloca i64
// CHECK: %[[VAL_2:.*]] = fir.alloca !fir.box<!fir.heap<i64>>
// CHECK: %[[VAL_3:.*]] = fir.alloca i64
// CHECK: %[[VAL_4:.*]] = arith.constant 10 : i64
// CHECK: %[[VAL_5:.*]] = arith.constant 1 : i64
// CHECK: %[[VAL_6:.*]] = arith.constant 10 : index
// CHECK: %[[VAL_7:.*]] = fir.dummy_scope : !fir.dscope
// CHECK: %[[VAL_8:.*]] = fir.shape %[[VAL_6]] : (index) -> !fir.shape<1>
// CHECK: %[[VAL_9:.*]]:2 = hlfir.declare{{.*}}x
// CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_5]] : (i64) -> index
// CHECK: %[[VAL_11:.*]] = fir.convert %[[VAL_4]] : (i64) -> index
// CHECK: %[[VAL_12:.*]] = arith.constant 1 : index
// CHECK: %[[VAL_13:.*]] = arith.constant 0 : i64
// CHECK: %[[VAL_14:.*]] = arith.constant 1 : i64
// CHECK: fir.store %[[VAL_13]] to %[[VAL_3]] : !fir.ref<i64>
// CHECK: %[[VAL_19:.*]] = fir.call @_FortranACreateValueStack(
// CHECK: fir.do_loop %[[VAL_20:.*]] = %[[VAL_10]] to %[[VAL_11]] step %[[VAL_12]] {
// CHECK: %[[VAL_21:.*]] = fir.convert %[[VAL_20]] : (index) -> i64
// CHECK: %[[VAL_22:.*]] = hlfir.designate %[[VAL_9]]#0 (%[[VAL_6]]) : (!fir.ref<!fir.array<10x!fir.type<t{p:!fir.boxproc<() -> i32>}>>>, index) -> !fir.ref<!fir.type<t{p:!fir.boxproc<() -> i32>}>>
// CHECK: %[[VAL_23:.*]] = hlfir.designate %[[VAL_22]]{"p"} {fortran_attrs = #fir.var_attrs<pointer>} : (!fir.ref<!fir.type<t{p:!fir.boxproc<() -> i32>}>>) -> !fir.ref<!fir.boxproc<() -> i32>>
// CHECK: %[[VAL_24:.*]] = fir.load %[[VAL_23]] : !fir.ref<!fir.boxproc<() -> i32>>
// CHECK: %[[VAL_25:.*]] = fir.box_addr %[[VAL_24]] : (!fir.boxproc<() -> i32>) -> (() -> i32)
// CHECK: %[[VAL_26:.*]] = fir.convert %[[VAL_25]] : (() -> i32) -> i64
// CHECK: fir.store %[[VAL_26]] to %[[VAL_1]] : !fir.ref<i64>
// CHECK: %[[VAL_27:.*]] = fir.embox %[[VAL_1]] : (!fir.ref<i64>) -> !fir.box<i64>
// CHECK: %[[VAL_28:.*]] = fir.convert %[[VAL_27]] : (!fir.box<i64>) -> !fir.box<none>
// CHECK: fir.call @_FortranAPushValue(%[[VAL_19]], %[[VAL_28]]) : (!fir.llvm_ptr<i8>, !fir.box<none>) -> ()
// CHECK: }
// CHECK: %[[VAL_29:.*]] = fir.convert %[[VAL_5]] : (i64) -> index
// CHECK: %[[VAL_30:.*]] = fir.convert %[[VAL_4]] : (i64) -> index
// CHECK: %[[VAL_31:.*]] = arith.constant 1 : index
// CHECK: fir.store %[[VAL_13]] to %[[VAL_3]] : !fir.ref<i64>
// CHECK: fir.do_loop %[[VAL_32:.*]] = %[[VAL_29]] to %[[VAL_30]] step %[[VAL_31]] {
// CHECK: %[[VAL_33:.*]] = fir.convert %[[VAL_32]] : (index) -> i64
// CHECK: %[[VAL_34:.*]] = hlfir.designate %[[VAL_9]]#0 (%[[VAL_33]]) : (!fir.ref<!fir.array<10x!fir.type<t{p:!fir.boxproc<() -> i32>}>>>, i64) -> !fir.ref<!fir.type<t{p:!fir.boxproc<() -> i32>}>>
// CHECK: %[[VAL_35:.*]] = hlfir.designate %[[VAL_34]]{"p"} {fortran_attrs = #fir.var_attrs<pointer>} : (!fir.ref<!fir.type<t{p:!fir.boxproc<() -> i32>}>>) -> !fir.ref<!fir.boxproc<() -> i32>>
// CHECK: %[[VAL_36:.*]] = fir.load %[[VAL_3]] : !fir.ref<i64>
// CHECK: %[[VAL_37:.*]] = arith.addi %[[VAL_36]], %[[VAL_14]] : i64
// CHECK: fir.store %[[VAL_37]] to %[[VAL_3]] : !fir.ref<i64>
// CHECK: %[[VAL_38:.*]] = fir.convert %[[VAL_2]] : (!fir.ref<!fir.box<!fir.heap<i64>>>) -> !fir.ref<!fir.box<none>>
// CHECK: fir.call @_FortranAValueAt(%[[VAL_19]], %[[VAL_36]], %[[VAL_38]]) : (!fir.llvm_ptr<i8>, i64, !fir.ref<!fir.box<none>>) -> ()
// CHECK: %[[VAL_39:.*]] = fir.load %[[VAL_2]] : !fir.ref<!fir.box<!fir.heap<i64>>>
// CHECK: %[[VAL_40:.*]] = fir.box_addr %[[VAL_39]] : (!fir.box<!fir.heap<i64>>) -> !fir.heap<i64>
// CHECK: %[[VAL_41:.*]] = fir.load %[[VAL_40]] : !fir.heap<i64>
// CHECK: %[[VAL_42:.*]] = fir.convert %[[VAL_41]] : (i64) -> (() -> i32)
// CHECK: %[[VAL_43:.*]] = fir.emboxproc %[[VAL_42]] : (() -> i32) -> !fir.boxproc<() -> i32>
// CHECK: fir.store %[[VAL_43]] to %[[VAL_35]] : !fir.ref<!fir.boxproc<() -> i32>>
// CHECK: }
// CHECK: fir.call @_FortranADestroyValueStack(%[[VAL_19]]) : (!fir.llvm_ptr<i8>) -> ()
// CHECK: return
// CHECK: }
func.func @test_need_to_save_lhs(%arg0: !fir.ref<!fir.array<10x!t>>) {
%c11_i64 = arith.constant 11 : i64
%c10_i64 = arith.constant 10 : i64
%c1_i64 = arith.constant 1 : i64
%c10 = arith.constant 10 : index
%0 = fir.dummy_scope : !fir.dscope
%1 = fir.shape %c10 : (index) -> !fir.shape<1>
%2:2 = hlfir.declare %arg0(%1) dummy_scope %0 {uniq_name = "x"} : (!fir.ref<!fir.array<10x!t>>, !fir.shape<1>, !fir.dscope) -> (!fir.ref<!fir.array<10x!t>>, !fir.ref<!fir.array<10x!t>>)
hlfir.forall lb {
hlfir.yield %c1_i64 : i64
} ub {
hlfir.yield %c10_i64 : i64
} (%arg1: i64) {
hlfir.region_assign {
%3 = fir.address_of(@f1) : () -> i32
%4 = fir.emboxproc %3 : (() -> i32) -> !fir.boxproc<() -> ()>
hlfir.yield %4 : !fir.boxproc<() -> ()>
} to {
%3 = arith.subi %c11_i64, %arg1 : i64
%4 = hlfir.designate %2#0 (%3) : (!fir.ref<!fir.array<10x!t>>, i64) -> !fir.ref<!t>
%5 = hlfir.designate %4{"p"} {fortran_attrs = #fir.var_attrs<pointer>} : (!fir.ref<!t>) -> !fir.ref<!fir.boxproc<() -> i32>>
%6 = fir.load %5 : !fir.ref<!fir.boxproc<() -> i32>>
%7 = fir.box_addr %6 : (!fir.boxproc<() -> i32>) -> (() -> i32)
%8 = fir.call %7() proc_attrs<pure> : () -> i32
%9 = fir.convert %8 : (i32) -> i64
%10 = hlfir.designate %2#0 (%9) : (!fir.ref<!fir.array<10x!t>>, i64) -> !fir.ref<!t>
%11 = hlfir.designate %10{"p"} {fortran_attrs = #fir.var_attrs<pointer>} : (!fir.ref<!t>) -> !fir.ref<!fir.boxproc<() -> i32>>
hlfir.yield %11 : !fir.ref<!fir.boxproc<() -> i32>>
}
}
return
}
// CHECK-LABEL: func.func @test_need_to_save_lhs(
// CHECK: %[[VAL_1:.*]] = fir.alloca i64
// CHECK: %[[VAL_2:.*]] = fir.alloca !fir.box<!fir.heap<i64>>
// CHECK: %[[VAL_3:.*]] = fir.alloca i64
// CHECK: %[[VAL_4:.*]] = arith.constant 11 : i64
// CHECK: %[[VAL_5:.*]] = arith.constant 10 : i64
// CHECK: %[[VAL_6:.*]] = arith.constant 1 : i64
// CHECK: %[[VAL_7:.*]] = arith.constant 10 : index
// CHECK: %[[VAL_8:.*]] = fir.dummy_scope : !fir.dscope
// CHECK: %[[VAL_9:.*]] = fir.shape %[[VAL_7]] : (index) -> !fir.shape<1>
// CHECK: %[[VAL_10:.*]]:2 = hlfir.declare{{.*}}"x"
// CHECK: %[[VAL_11:.*]] = fir.convert %[[VAL_6]] : (i64) -> index
// CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_5]] : (i64) -> index
// CHECK: %[[VAL_13:.*]] = arith.constant 1 : index
// CHECK: %[[VAL_14:.*]] = arith.constant 0 : i64
// CHECK: %[[VAL_15:.*]] = arith.constant 1 : i64
// CHECK: fir.store %[[VAL_14]] to %[[VAL_3]] : !fir.ref<i64>
// CHECK: %[[VAL_20:.*]] = fir.call @_FortranACreateValueStack(
// CHECK: fir.do_loop %[[VAL_21:.*]] = %[[VAL_11]] to %[[VAL_12]] step %[[VAL_13]] {
// CHECK: %[[VAL_22:.*]] = fir.convert %[[VAL_21]] : (index) -> i64
// CHECK: %[[VAL_23:.*]] = arith.subi %[[VAL_4]], %[[VAL_22]] : i64
// CHECK: %[[VAL_24:.*]] = hlfir.designate %[[VAL_10]]#0 (%[[VAL_23]]) : (!fir.ref<!fir.array<10x!fir.type<t{p:!fir.boxproc<() -> i32>}>>>, i64) -> !fir.ref<!fir.type<t{p:!fir.boxproc<() -> i32>}>>
// CHECK: %[[VAL_25:.*]] = hlfir.designate %[[VAL_24]]{"p"} {fortran_attrs = #fir.var_attrs<pointer>} : (!fir.ref<!fir.type<t{p:!fir.boxproc<() -> i32>}>>) -> !fir.ref<!fir.boxproc<() -> i32>>
// CHECK: %[[VAL_26:.*]] = fir.load %[[VAL_25]] : !fir.ref<!fir.boxproc<() -> i32>>
// CHECK: %[[VAL_27:.*]] = fir.box_addr %[[VAL_26]] : (!fir.boxproc<() -> i32>) -> (() -> i32)
// CHECK: %[[VAL_28:.*]] = fir.call %[[VAL_27]]() proc_attrs<pure> : () -> i32
// CHECK: %[[VAL_29:.*]] = fir.convert %[[VAL_28]] : (i32) -> i64
// CHECK: %[[VAL_30:.*]] = hlfir.designate %[[VAL_10]]#0 (%[[VAL_29]]) : (!fir.ref<!fir.array<10x!fir.type<t{p:!fir.boxproc<() -> i32>}>>>, i64) -> !fir.ref<!fir.type<t{p:!fir.boxproc<() -> i32>}>>
// CHECK: %[[VAL_31:.*]] = hlfir.designate %[[VAL_30]]{"p"} {fortran_attrs = #fir.var_attrs<pointer>} : (!fir.ref<!fir.type<t{p:!fir.boxproc<() -> i32>}>>) -> !fir.ref<!fir.boxproc<() -> i32>>
// CHECK: %[[VAL_32:.*]] = fir.convert %[[VAL_31]] : (!fir.ref<!fir.boxproc<() -> i32>>) -> i64
// CHECK: fir.store %[[VAL_32]] to %[[VAL_1]] : !fir.ref<i64>
// CHECK: %[[VAL_33:.*]] = fir.embox %[[VAL_1]] : (!fir.ref<i64>) -> !fir.box<i64>
// CHECK: %[[VAL_34:.*]] = fir.convert %[[VAL_33]] : (!fir.box<i64>) -> !fir.box<none>
// CHECK: fir.call @_FortranAPushValue(%[[VAL_20]], %[[VAL_34]]) : (!fir.llvm_ptr<i8>, !fir.box<none>) -> ()
// CHECK: }
// CHECK: %[[VAL_35:.*]] = fir.convert %[[VAL_6]] : (i64) -> index
// CHECK: %[[VAL_36:.*]] = fir.convert %[[VAL_5]] : (i64) -> index
// CHECK: %[[VAL_37:.*]] = arith.constant 1 : index
// CHECK: fir.store %[[VAL_14]] to %[[VAL_3]] : !fir.ref<i64>
// CHECK: fir.do_loop %[[VAL_38:.*]] = %[[VAL_35]] to %[[VAL_36]] step %[[VAL_37]] {
// CHECK: %[[VAL_39:.*]] = fir.convert %[[VAL_38]] : (index) -> i64
// CHECK: %[[VAL_40:.*]] = fir.load %[[VAL_3]] : !fir.ref<i64>
// CHECK: %[[VAL_41:.*]] = arith.addi %[[VAL_40]], %[[VAL_15]] : i64
// CHECK: fir.store %[[VAL_41]] to %[[VAL_3]] : !fir.ref<i64>
// CHECK: %[[VAL_42:.*]] = fir.convert %[[VAL_2]] : (!fir.ref<!fir.box<!fir.heap<i64>>>) -> !fir.ref<!fir.box<none>>
// CHECK: fir.call @_FortranAValueAt(%[[VAL_20]], %[[VAL_40]], %[[VAL_42]]) : (!fir.llvm_ptr<i8>, i64, !fir.ref<!fir.box<none>>) -> ()
// CHECK: %[[VAL_43:.*]] = fir.load %[[VAL_2]] : !fir.ref<!fir.box<!fir.heap<i64>>>
// CHECK: %[[VAL_44:.*]] = fir.box_addr %[[VAL_43]] : (!fir.box<!fir.heap<i64>>) -> !fir.heap<i64>
// CHECK: %[[VAL_45:.*]] = fir.load %[[VAL_44]] : !fir.heap<i64>
// CHECK: %[[VAL_46:.*]] = fir.convert %[[VAL_45]] : (i64) -> !fir.ref<!fir.boxproc<() -> i32>>
// CHECK: %[[VAL_47:.*]] = fir.address_of(@f1) : () -> i32
// CHECK: %[[VAL_48:.*]] = fir.emboxproc %[[VAL_47]] : (() -> i32) -> !fir.boxproc<() -> ()>
// CHECK: %[[VAL_49:.*]] = fir.convert %[[VAL_48]] : (!fir.boxproc<() -> ()>) -> !fir.boxproc<() -> i32>
// CHECK: fir.store %[[VAL_49]] to %[[VAL_46]] : !fir.ref<!fir.boxproc<() -> i32>>
// CHECK: }
// CHECK: fir.call @_FortranADestroyValueStack(%[[VAL_20]]) : (!fir.llvm_ptr<i8>) -> ()
// CHECK: return
// CHECK: }
func.func private @f1() -> i32 attributes {fir.proc_attrs = #fir.proc_attrs<pure>}

126
flang/test/HLFIR/order_assignments/forall-proc-pointer-assignment-scheduling-character.f90 Normal file
View File

@@ -0,0 +1,126 @@
! Test analysis of character procedure pointer assignments inside FORALL.
! Character procedure gets their own tests because they are tracked differently
! in FIR because of the length of the function result.
! RUN: bbc -hlfir -o /dev/null -pass-pipeline="builtin.module(lower-hlfir-ordered-assignments)" \
! RUN: --debug-only=flang-ordered-assignment -flang-dbg-order-assignment-schedule-only -I nw %s 2>&1 | FileCheck %s
! REQUIRES: asserts
module char_proc_ptr_forall
type :: t
procedure(f1), nopass, pointer :: p
end type
contains
pure character(2) function f1()
f1 = "01"
end function
pure character(2) function f2()
f2 = "02"
end function
pure character(2) function f3()
f3 = "03"
end function
pure character(2) function f4()
f4 = "04"
end function
pure character(2) function f5()
f5 = "05"
end function
pure character(2) function f6()
f6 = "06"
end function
pure character(2) function f7()
f7 = "07"
end function
pure character(2) function f8()
f8 = "08"
end function
pure character(2) function f9()
f9 = "09"
end function
pure character(2) function f10()
f10 = "10"
end function
integer pure function decode(c)
character(2), intent(in) :: c
decode = modulo(iachar(c(2:2))-49,10)+1
end function
subroutine test_no_conflict(x)
type(t) :: x(10)
forall(i=1:10) x(i)%p => f1
end subroutine
! CHECK: ------------ scheduling forall in _QMchar_proc_ptr_forallPtest_no_conflict ------------
! CHECK-NEXT: run 1 evaluate: forall/region_assign1
subroutine test_need_to_save_rhs(x)
type(t) :: x(10)
forall(i=1:10) x(i)%p => x(11-i)%p
end subroutine
! CHECK: ------------ scheduling forall in _QMchar_proc_ptr_forallPtest_need_to_save_rhs ------------
! CHECK-NEXT: conflict: R/W
! CHECK-NEXT: run 1 save : forall/region_assign1/rhs
! CHECK-NEXT: run 2 evaluate: forall/region_assign1
subroutine test_need_to_save_lhs(x)
type(t) :: x(10)
forall(i=1:10) x(decode(x(11-i)%p()))%p => f1
end subroutine
! CHECK: ------------ scheduling forall in _QMchar_proc_ptr_forallPtest_need_to_save_lhs ------------
! CHECK: conflict: R/W
! CHECK-NEXT: run 1 save : forall/region_assign1/lhs
! CHECK-NEXT: run 2 evaluate: forall/region_assign1
subroutine test_need_to_save_lhs_and_rhs(x)
type(t) :: x(10)
forall(i=1:10) x(decode(x(11-i)%p()))%p => x(modulo(-2*i, 11))%p
end subroutine
! CHECK: ------------ scheduling forall in _QMchar_proc_ptr_forallPtest_need_to_save_lhs_and_rhs ------------
! CHECK: conflict: R/W
! CHECK-NEXT: run 1 save : forall/region_assign1/rhs
! CHECK: conflict: R/W
! CHECK-NEXT: run 1 save : forall/region_assign1/lhs
! CHECK-NEXT: run 2 evaluate: forall/region_assign1
! End-to-end test utilities for debugging purposes.
subroutine reset(a)
type(t) :: a(:)
a = [t(f10), t(f9), t(f8), t(f7), t(f6), t(f5), t(f4), t(f3), t(f2), t(f1)]
end subroutine
subroutine print(a)
type(t) :: a(:)
print *, [(decode(a(i)%p()), i=1,10)]
end subroutine
logical function check_equal(a, expected)
type(t) :: a(:)
integer :: expected(:)
check_equal = all([(decode(a(i)%p()), i=1,10)].eq.expected)
if (.not.check_equal) then
print *, "expected:", expected
print *, "got:", [(decode(a(i)%p()), i=1,10)]
end if
end function
end module
! End-to-end test for debugging purposes (not verified by lit).
use char_proc_ptr_forall
type(t) :: a(10)
call reset(a)
call test_need_to_save_rhs(a)
if (.not.check_equal(a, [1, 2, 3, 4, 5, 6, 7, 8, 9, 10])) stop 1
call reset(a)
call test_need_to_save_lhs(a)
if (.not.check_equal(a, [1, 1, 1, 1, 1, 1, 1, 1, 1, 1])) stop 2
call reset(a)
call test_need_to_save_lhs_and_rhs(a)
if (.not.check_equal(a, [2, 4, 6, 8, 10, 1, 3, 5, 7, 9])) stop 3
print *, "PASS"
end

123
flang/test/HLFIR/order_assignments/forall-proc-pointer-assignment-scheduling.f90 Normal file
View File

@@ -0,0 +1,123 @@
! Test analysis of procedure pointer assignments inside FORALL.
! RUN: bbc -hlfir -o /dev/null -pass-pipeline="builtin.module(lower-hlfir-ordered-assignments)" \
! RUN: --debug-only=flang-ordered-assignment -flang-dbg-order-assignment-schedule-only -I nw %s 2>&1 | FileCheck %s
! REQUIRES: asserts
module proc_ptr_forall
type :: t
procedure(f1), nopass, pointer :: p
end type
contains
pure integer function f1()
f1 = 1
end function
pure integer function f2()
f2 = 2
end function
pure integer function f3()
f3 = 3
end function
pure integer function f4()
f4 = 4
end function
pure integer function f5()
f5 = 5
end function
pure integer function f6()
f6 = 6
end function
pure integer function f7()
f7 = 7
end function
pure integer function f8()
f8 = 8
end function
pure integer function f9()
f9 = 9
end function
pure integer function f10()
f10 = 10
end function
subroutine test_no_conflict(x)
type(t) :: x(10)
forall(i=1:10) x(i)%p => f1
end subroutine
! CHECK: ------------ scheduling forall in _QMproc_ptr_forallPtest_no_conflict ------------
! CHECK-NEXT: run 1 evaluate: forall/region_assign1
subroutine test_need_to_save_rhs(x)
type(t) :: x(10)
forall(i=1:10) x(i)%p => x(11-i)%p
end subroutine
! CHECK: ------------ scheduling forall in _QMproc_ptr_forallPtest_need_to_save_rhs ------------
! CHECK-NEXT: conflict: R/W
! CHECK-NEXT: run 1 save : forall/region_assign1/rhs
! CHECK-NEXT: run 2 evaluate: forall/region_assign1
subroutine test_need_to_save_lhs(x)
type(t) :: x(10)
forall(i=1:10) x(x(11-i)%p())%p => f1
end subroutine
! CHECK: ------------ scheduling forall in _QMproc_ptr_forallPtest_need_to_save_lhs ------------
! CHECK-NEXT: unknown effect: %{{.*}} = fir.call
! CHECK-NEXT: unknown effect: %{{.*}} = fir.call
! CHECK-NEXT: conflict: R/W
! CHECK-NEXT: run 1 save : forall/region_assign1/lhs
! CHECK-NEXT: run 2 evaluate: forall/region_assign1
subroutine test_need_to_save_lhs_and_rhs(x)
type(t) :: x(10)
forall(i=1:10) x(x(11-i)%p())%p => x(modulo(-2*i, 11))%p
end subroutine
! CHECK: ------------ scheduling forall in _QMproc_ptr_forallPtest_need_to_save_lhs_and_rhs ------------
! CHECK-NEXT: unknown effect: %{{.*}} = fir.call
! CHECK-NEXT: conflict: R/W
! CHECK-NEXT: run 1 save : forall/region_assign1/rhs
! CHECK-NEXT: unknown effect: %{{.*}} = fir.call
! CHECK-NEXT: conflict: R/W
! CHECK-NEXT: run 1 save : forall/region_assign1/lhs
! CHECK-NEXT: run 2 evaluate: forall/region_assign1
! End-to-end test utilities for debugging purposes.
subroutine reset(a)
type(t) :: a(:)
a = [t(f10), t(f9), t(f8), t(f7), t(f6), t(f5), t(f4), t(f3), t(f2), t(f1)]
end subroutine
subroutine print(a)
type(t) :: a(:)
print *, [(a(i)%p(), i=1,10)]
end subroutine
logical function check_equal(a, expected)
type(t) :: a(:)
integer :: expected(:)
check_equal = all([(a(i)%p(), i=1,10)].eq.expected)
if (.not.check_equal) then
print *, "expected:", expected
print *, "got:", [(a(i)%p(), i=1,10)]
end if
end function
end module
! End-to-end test for debugging purposes (not verified by lit).
use proc_ptr_forall
type(t) :: a(10)
call reset(a)
call test_need_to_save_rhs(a)
if (.not.check_equal(a, [1, 2, 3, 4, 5, 6, 7, 8, 9, 10])) stop 1
call reset(a)
call test_need_to_save_lhs(a)
if (.not.check_equal(a, [1, 1, 1, 1, 1, 1, 1, 1, 1, 1])) stop 2
call reset(a)
call test_need_to_save_lhs_and_rhs(a)
if (.not.check_equal(a, [2, 4, 6, 8, 10, 1, 3, 5, 7, 9])) stop 3
print *, "PASS"
end