[flang-commits] [flang] [flang] add support for procedure pointer assignment inside FORALL (PR #130114)
via flang-commits
flang-commits at lists.llvm.org
Thu Mar 6 06:47:50 PST 2025
https://github.com/jeanPerier created https://github.com/llvm/llvm-project/pull/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).
>From f08aedc38797ee7057379c4579360ce72e0b2c5a Mon Sep 17 00:00:00 2001
From: Jean Perier <jperier at nvidia.com>
Date: Thu, 6 Mar 2025 06:16:53 -0800
Subject: [PATCH] [flang] add support for procedure pointer assignment inside
FORALL
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).
---
.../flang/Optimizer/Builder/HLFIRTools.h | 2 +-
.../Optimizer/Builder/TemporaryStorage.h | 19 +-
.../flang/Optimizer/HLFIR/HLFIRDialect.h | 11 +
.../flang/Optimizer/HLFIR/HLFIROpBase.td | 7 +-
.../include/flang/Optimizer/HLFIR/HLFIROps.td | 2 +
flang/lib/Lower/Bridge.cpp | 27 ++-
.../Optimizer/Builder/TemporaryStorage.cpp | 36 +--
flang/lib/Optimizer/HLFIR/IR/HLFIROps.cpp | 31 ++-
.../LowerHLFIROrderedAssignments.cpp | 10 +-
...forall-proc-pointer-assignment-codegen.f90 | 222 ++++++++++++++++++
...ointer-assignment-scheduling-character.f90 | 126 ++++++++++
...all-proc-pointer-assignment-scheduling.f90 | 123 ++++++++++
12 files changed, 567 insertions(+), 49 deletions(-)
create mode 100644 flang/test/HLFIR/order_assignments/forall-proc-pointer-assignment-codegen.f90
create mode 100644 flang/test/HLFIR/order_assignments/forall-proc-pointer-assignment-scheduling-character.f90
create mode 100644 flang/test/HLFIR/order_assignments/forall-proc-pointer-assignment-scheduling.f90
diff --git a/flang/include/flang/Optimizer/Builder/HLFIRTools.h b/flang/include/flang/Optimizer/Builder/HLFIRTools.h
index 19fc2c22f0d49..ac80873dc374f 100644
--- a/flang/include/flang/Optimizer/Builder/HLFIRTools.h
+++ b/flang/include/flang/Optimizer/Builder/HLFIRTools.h
@@ -60,7 +60,7 @@ class Entity : public mlir::Value {
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());
diff --git a/flang/include/flang/Optimizer/Builder/TemporaryStorage.h b/flang/include/flang/Optimizer/Builder/TemporaryStorage.h
index b17a75354e7d1..cdb23a64c5c8a 100644
--- a/flang/include/flang/Optimizer/Builder/TemporaryStorage.h
+++ b/flang/include/flang/Optimizer/Builder/TemporaryStorage.h
@@ -180,7 +180,7 @@ class AnyValueStack {
/// 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 @@ class AnyVariableStack {
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 @@ class TemporaryStorage {
private:
std::variant<HomogeneousScalarStack, SimpleCopy, SSARegister, AnyValueStack,
- AnyVariableStack, AnyVectorSubscriptStack,
- AnyDescriptorAddressStack>
+ AnyVariableStack, AnyVectorSubscriptStack, AnyAddressStack>
impl;
};
} // namespace fir::factory
diff --git a/flang/include/flang/Optimizer/HLFIR/HLFIRDialect.h b/flang/include/flang/Optimizer/HLFIR/HLFIRDialect.h
index 15296aa7e8c75..5152dee14ad65 100644
--- a/flang/include/flang/Optimizer/HLFIR/HLFIRDialect.h
+++ b/flang/include/flang/Optimizer/HLFIR/HLFIRDialect.h
@@ -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) {
diff --git a/flang/include/flang/Optimizer/HLFIR/HLFIROpBase.td b/flang/include/flang/Optimizer/HLFIR/HLFIROpBase.td
index 1b1ac61d4550f..ee0b5aa9760b1 100644
--- a/flang/include/flang/Optimizer/HLFIR/HLFIROpBase.td
+++ b/flang/include/flang/Optimizer/HLFIR/HLFIROpBase.td
@@ -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,
diff --git a/flang/include/flang/Optimizer/HLFIR/HLFIROps.td b/flang/include/flang/Optimizer/HLFIR/HLFIROps.td
index c12066b1346f6..f69930d5b53b3 100644
--- a/flang/include/flang/Optimizer/HLFIR/HLFIROps.td
+++ b/flang/include/flang/Optimizer/HLFIR/HLFIROps.td
@@ -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;
diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp
index 95f431983d442..2b2f0d9bcccd5 100644
--- a/flang/lib/Lower/Bridge.cpp
+++ b/flang/lib/Lower/Bridge.cpp
@@ -4353,8 +4353,6 @@ class FirConverter : public Fortran::lower::AbstractConverter {
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 @@ class FirConverter : public Fortran::lower::AbstractConverter {
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 @@ class FirConverter : public Fortran::lower::AbstractConverter {
// Lower RHS in its own region.
builder->createBlock(®ionAssignOp.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 @@ class FirConverter : public Fortran::lower::AbstractConverter {
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
diff --git a/flang/lib/Optimizer/Builder/TemporaryStorage.cpp b/flang/lib/Optimizer/Builder/TemporaryStorage.cpp
index 48c2cb2181a0b..9d2e9837a3df8 100644
--- a/flang/lib/Optimizer/Builder/TemporaryStorage.cpp
+++ b/flang/lib/Optimizer/Builder/TemporaryStorage.cpp
@@ -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} {}
-
-void fir::factory::AnyDescriptorAddressStack::pushValue(
- mlir::Location loc, fir::FirOpBuilder &builder, mlir::Value variable) {
- mlir::Value cast =
- builder.createConvert(loc, builder.getIntPtrType(), variable);
+ addressType{addressType} {}
+
+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);
}
diff --git a/flang/lib/Optimizer/HLFIR/IR/HLFIROps.cpp b/flang/lib/Optimizer/HLFIR/IR/HLFIROps.cpp
index 383e6a2630537..8851a3a7187b9 100644
--- a/flang/lib/Optimizer/HLFIR/IR/HLFIROps.cpp
+++ b/flang/lib/Optimizer/HLFIR/IR/HLFIROps.cpp
@@ -1891,18 +1891,33 @@ llvm::LogicalResult hlfir::RegionAssignOp::verify() {
return mlir::success();
}
-bool hlfir::RegionAssignOp::isPointerAssignment() {
+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;
- hlfir::YieldOp yieldOp =
- mlir::dyn_cast_or_null<hlfir::YieldOp>(getTerminator(getLhsRegion()));
- if (!yieldOp)
+ mlir::Type lhsType = getNonVectorSubscriptedLhsType(*this);
+ return lhsType && hlfir::isFortranPointerObjectType(lhsType);
+}
+
+bool hlfir::RegionAssignOp::isProcedurePointerAssignment() {
+ if (!getUserDefinedAssignment().empty())
return false;
- mlir::Type lhsType = yieldOp.getEntity().getType();
- if (!hlfir::isBoxAddressType(lhsType))
+ mlir::Type lhsType = getNonVectorSubscriptedLhsType(*this);
+ return lhsType && hlfir::isFortranProcedurePointerType(lhsType);
+}
+
+bool hlfir::RegionAssignOp::isPointerAssignment() {
+ if (!getUserDefinedAssignment().empty())
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));
}
//===----------------------------------------------------------------------===//
diff --git a/flang/lib/Optimizer/HLFIR/Transforms/LowerHLFIROrderedAssignments.cpp b/flang/lib/Optimizer/HLFIR/Transforms/LowerHLFIROrderedAssignments.cpp
index 7561daefa3b83..5cae7cf443c86 100644
--- a/flang/lib/Optimizer/HLFIR/Transforms/LowerHLFIROrderedAssignments.cpp
+++ b/flang/lib/Optimizer/HLFIR/Transforms/LowerHLFIROrderedAssignments.cpp
@@ -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()});
});
diff --git a/flang/test/HLFIR/order_assignments/forall-proc-pointer-assignment-codegen.f90 b/flang/test/HLFIR/order_assignments/forall-proc-pointer-assignment-codegen.f90
new file mode 100644
index 0000000000000..c5fcc4d943927
--- /dev/null
+++ b/flang/test/HLFIR/order_assignments/forall-proc-pointer-assignment-codegen.f90
@@ -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>}
diff --git a/flang/test/HLFIR/order_assignments/forall-proc-pointer-assignment-scheduling-character.f90 b/flang/test/HLFIR/order_assignments/forall-proc-pointer-assignment-scheduling-character.f90
new file mode 100644
index 0000000000000..d2d1939890882
--- /dev/null
+++ b/flang/test/HLFIR/order_assignments/forall-proc-pointer-assignment-scheduling-character.f90
@@ -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
diff --git a/flang/test/HLFIR/order_assignments/forall-proc-pointer-assignment-scheduling.f90 b/flang/test/HLFIR/order_assignments/forall-proc-pointer-assignment-scheduling.f90
new file mode 100644
index 0000000000000..ba9c203453d95
--- /dev/null
+++ b/flang/test/HLFIR/order_assignments/forall-proc-pointer-assignment-scheduling.f90
@@ -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
More information about the flang-commits
mailing list