[flang-commits] [flang] [flang] lower remaining cases of pointer assignments inside forall (PR #130772)
via flang-commits
flang-commits at lists.llvm.org
Thu Mar 13 02:11:54 PDT 2025
https://github.com/jeanPerier updated https://github.com/llvm/llvm-project/pull/130772
>From bdf3229ec163b9407e84cce84c85b9d99bfad62d Mon Sep 17 00:00:00 2001
From: Jean Perier <jperier at nvidia.com>
Date: Tue, 11 Mar 2025 06:03:47 -0700
Subject: [PATCH 1/2] [flang] lower remaining cases of pointer assignments
inside forall
---
.../flang/Optimizer/Builder/FIRBuilder.h | 10 ++
flang/lib/Lower/Bridge.cpp | 99 ++++++++++------
flang/lib/Lower/ConvertVariable.cpp | 18 +--
flang/lib/Optimizer/Builder/FIRBuilder.cpp | 31 ++++-
...l-pointer-assignment-scheduling-bounds.f90 | 93 +++++++++++++++
...nter-assignment-scheduling-polymorphic.f90 | 110 ++++++++++++++++++
.../forall-pointer-assignment-scheduling.f90 | 56 +++++++--
...all-proc-pointer-assignment-scheduling.f90 | 33 ++++++
.../acc-enter-data-unwrap-defaultbounds.f90 | 4 +-
flang/test/Lower/OpenACC/acc-enter-data.f90 | 4 +-
10 files changed, 393 insertions(+), 65 deletions(-)
create mode 100644 flang/test/HLFIR/order_assignments/forall-pointer-assignment-scheduling-bounds.f90
create mode 100644 flang/test/HLFIR/order_assignments/forall-pointer-assignment-scheduling-polymorphic.f90
diff --git a/flang/include/flang/Optimizer/Builder/FIRBuilder.h b/flang/include/flang/Optimizer/Builder/FIRBuilder.h
index 1675c15363868..003b4358572c1 100644
--- a/flang/include/flang/Optimizer/Builder/FIRBuilder.h
+++ b/flang/include/flang/Optimizer/Builder/FIRBuilder.h
@@ -774,9 +774,19 @@ mlir::Value createZeroValue(fir::FirOpBuilder &builder, mlir::Location loc,
std::optional<std::int64_t> getExtentFromTriplet(mlir::Value lb, mlir::Value ub,
mlir::Value stride);
+/// Compute the extent value given the lower bound \lb and upper bound \ub.
+/// All inputs must have the same SSA integer type.
+mlir::Value computeExtent(fir::FirOpBuilder &builder, mlir::Location loc,
+ mlir::Value lb, mlir::Value ub);
+mlir::Value computeExtent(fir::FirOpBuilder &builder, mlir::Location loc,
+ mlir::Value lb, mlir::Value ub, mlir::Value zero,
+ mlir::Value one);
+
/// Generate max(\p value, 0) where \p value is a scalar integer.
mlir::Value genMaxWithZero(fir::FirOpBuilder &builder, mlir::Location loc,
mlir::Value value);
+mlir::Value genMaxWithZero(fir::FirOpBuilder &builder, mlir::Location loc,
+ mlir::Value value, mlir::Value zero);
/// The type(C_PTR/C_FUNPTR) is defined as the derived type with only one
/// component of integer 64, and the component is the C address. Get the C
diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp
index 93f54d88a029d..d0b26ddc92133 100644
--- a/flang/lib/Lower/Bridge.cpp
+++ b/flang/lib/Lower/Bridge.cpp
@@ -4353,30 +4353,12 @@ class FirConverter : public Fortran::lower::AbstractConverter {
stmtCtx);
}
- void genForallPointerAssignment(
- mlir::Location loc, const Fortran::evaluate::Assignment &assign,
- const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) {
- std::optional<Fortran::evaluate::DynamicType> lhsType =
- assign.lhs.GetType();
- // Polymorphic pointer assignment is delegated to the runtime, and
- // PointerAssociateLowerBounds needs the lower bounds as arguments, so they
- // must be preserved.
- if (lhsType && lhsType->IsPolymorphic())
- TODO(loc, "polymorphic pointer assignment in FORALL");
- // Nullification is special, there is no RHS that can be prepared,
- // need to encode it in HLFIR.
- if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
- assign.rhs))
- TODO(loc, "NULL pointer assignment in FORALL");
- // Lower bounds could be "applied" when preparing RHS, but in order
- // to deal with the polymorphic case and to reuse existing pointer
- // assignment helpers in HLFIR codegen, it is better to keep them
- // separate.
- if (!lbExprs.empty())
- TODO(loc, "Pointer assignment with new lower bounds inside FORALL");
- // Otherwise, this is a "dumb" pointer assignment that can be represented
- // with hlfir.region_assign with descriptor address/value and later
- // implemented with a store.
+ void genForallPointerAssignment(mlir::Location loc,
+ const Fortran::evaluate::Assignment &assign) {
+ // Lower pointer assignment inside forall with hlfir.region_assign with
+ // descriptor address/value and later implemented with a store.
+ // The RHS is fully prepared in lowering, so that all that is left
+ // in hlfir.region_assign code generation is the store.
auto regionAssignOp = builder->create<hlfir::RegionAssignOp>(loc);
// Lower LHS in its own region.
@@ -4400,22 +4382,74 @@ class FirConverter : public Fortran::lower::AbstractConverter {
builder->setInsertionPointAfter(regionAssignOp);
}
+ mlir::Value lowerToIndexValue(mlir::Location loc,
+ const Fortran::evaluate::ExtentExpr &expr,
+ Fortran::lower::StatementContext &stmtCtx) {
+ mlir::Value val = fir::getBase(genExprValue(toEvExpr(expr), stmtCtx));
+ return builder->createConvert(loc, builder->getIndexType(), val);
+ }
+
mlir::Value
genForallPointerAssignmentRhs(mlir::Location loc, mlir::Value lhs,
const Fortran::evaluate::Assignment &assign,
Fortran::lower::StatementContext &rhsContext) {
- if (Fortran::evaluate::IsProcedureDesignator(assign.rhs))
+ if (Fortran::evaluate::IsProcedureDesignator(assign.lhs)) {
+ if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
+ assign.rhs))
+ return fir::factory::createNullBoxProc(
+ *builder, loc, fir::unwrapRefType(lhs.getType()));
return fir::getBase(Fortran::lower::convertExprToAddress(
loc, *this, assign.rhs, localSymbols, rhsContext));
+ }
// Data target.
+ auto lhsBoxType =
+ llvm::cast<fir::BaseBoxType>(fir::unwrapRefType(lhs.getType()));
+ // For NULL, create disassociated descriptor whose dynamic type is
+ // the static type of the LHS.
+ if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
+ assign.rhs))
+ return fir::factory::createUnallocatedBox(*builder, loc, lhsBoxType,
+ std::nullopt);
hlfir::Entity rhs = Fortran::lower::convertExprToHLFIR(
loc, *this, assign.rhs, localSymbols, rhsContext);
// Create pointer descriptor value from the RHS.
if (rhs.isMutableBox())
rhs = hlfir::Entity{builder->create<fir::LoadOp>(loc, rhs)};
- auto lhsBoxType =
- llvm::cast<fir::BaseBoxType>(fir::unwrapRefType(lhs.getType()));
- return hlfir::genVariableBox(loc, *builder, rhs, lhsBoxType);
+ mlir::Value rhsBox = hlfir::genVariableBox(
+ loc, *builder, rhs, lhsBoxType.getBoxTypeWithNewShape(rhs.getRank()));
+ mlir::Type indexTy = builder->getIndexType();
+ // Bounds
+ if (const auto *lbExprs =
+ std::get_if<Fortran::evaluate::Assignment::BoundsSpec>(&assign.u);
+ lbExprs && !lbExprs->empty()) {
+ // Override target lower bounds with the LHS bounds spec.
+ llvm::SmallVector<mlir::Value> lbounds;
+ for (const Fortran::evaluate::ExtentExpr &lbExpr : *lbExprs)
+ lbounds.push_back(lowerToIndexValue(loc, lbExpr, rhsContext));
+ mlir::Value shift = builder->genShift(loc, lbounds);
+ rhsBox = builder->create<fir::ReboxOp>(loc, lhsBoxType, rhsBox, shift,
+ /*slice=*/mlir::Value{});
+ } else if (const auto *boundExprs =
+ std::get_if<Fortran::evaluate::Assignment::BoundsRemapping>(
+ &assign.u);
+ boundExprs && !boundExprs->empty()) {
+ // Reshape the target according to the LHS bounds remapping.
+ llvm::SmallVector<mlir::Value> lbounds;
+ llvm::SmallVector<mlir::Value> extents;
+ mlir::Type indexTy = builder->getIndexType();
+ mlir::Value zero = builder->createIntegerConstant(loc, indexTy, 0);
+ mlir::Value one = builder->createIntegerConstant(loc, indexTy, 1);
+ for (const auto &[lbExpr, ubExpr] : *boundExprs) {
+ lbounds.push_back(lowerToIndexValue(loc, lbExpr, rhsContext));
+ mlir::Value ub = lowerToIndexValue(loc, ubExpr, rhsContext);
+ extents.push_back(fir::factory::computeExtent(
+ *builder, loc, lbounds.back(), ub, zero, one));
+ }
+ mlir::Value shape = builder->genShape(loc, lbounds, extents);
+ rhsBox = builder->create<fir::ReboxOp>(loc, lhsBoxType, rhsBox, shape,
+ /*slice=*/mlir::Value{});
+ }
+ return rhsBox;
}
// Create the 2 x newRank array with the bounds to be passed to the runtime as
@@ -4856,17 +4890,16 @@ class FirConverter : public Fortran::lower::AbstractConverter {
},
[&](const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) {
if (isInsideHlfirForallOrWhere())
- genForallPointerAssignment(loc, assign, lbExprs);
+ genForallPointerAssignment(loc, assign);
else
genPointerAssignment(loc, assign, lbExprs);
},
[&](const Fortran::evaluate::Assignment::BoundsRemapping
&boundExprs) {
if (isInsideHlfirForallOrWhere())
- TODO(
- loc,
- "pointer assignment with bounds remapping inside FORALL");
- genPointerAssignment(loc, assign, boundExprs);
+ genForallPointerAssignment(loc, assign);
+ else
+ genPointerAssignment(loc, assign, boundExprs);
},
},
assign.u);
diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp
index 295158f153121..ae6db34e6e06e 100644
--- a/flang/lib/Lower/ConvertVariable.cpp
+++ b/flang/lib/Lower/ConvertVariable.cpp
@@ -1519,17 +1519,6 @@ static bool lowerToBoxValue(const Fortran::semantics::Symbol &sym,
return false;
}
-/// Compute extent from lower and upper bound.
-static mlir::Value computeExtent(fir::FirOpBuilder &builder, mlir::Location loc,
- mlir::Value lb, mlir::Value ub) {
- mlir::IndexType idxTy = builder.getIndexType();
- // Let the folder deal with the common `ub - <const> + 1` case.
- auto diff = builder.create<mlir::arith::SubIOp>(loc, idxTy, ub, lb);
- mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
- auto rawExtent = builder.create<mlir::arith::AddIOp>(loc, idxTy, diff, one);
- return fir::factory::genMaxWithZero(builder, loc, rawExtent);
-}
-
/// Lower explicit lower bounds into \p result. Does nothing if this is not an
/// array, or if the lower bounds are deferred, or all implicit or one.
static void lowerExplicitLowerBounds(
@@ -1593,8 +1582,8 @@ lowerExplicitExtents(Fortran::lower::AbstractConverter &converter,
if (lowerBounds.empty())
result.emplace_back(fir::factory::genMaxWithZero(builder, loc, ub));
else
- result.emplace_back(
- computeExtent(builder, loc, lowerBounds[spec.index()], ub));
+ result.emplace_back(fir::factory::computeExtent(
+ builder, loc, lowerBounds[spec.index()], ub));
} else if (spec.value()->ubound().isStar()) {
result.emplace_back(getAssumedSizeExtent(loc, builder));
}
@@ -2214,7 +2203,8 @@ void Fortran::lower::mapSymbolAttributes(
if (auto high = spec->ubound().GetExplicit()) {
auto expr = Fortran::lower::SomeExpr{*high};
ub = builder.createConvert(loc, idxTy, genValue(expr));
- extents.emplace_back(computeExtent(builder, loc, lb, ub));
+ extents.emplace_back(
+ fir::factory::computeExtent(builder, loc, lb, ub));
} else {
// An assumed size array. The extent is not computed.
assert(spec->ubound().isStar() && "expected assumed size");
diff --git a/flang/lib/Optimizer/Builder/FIRBuilder.cpp b/flang/lib/Optimizer/Builder/FIRBuilder.cpp
index b3d440cedee07..b7f8a8d3a9d56 100644
--- a/flang/lib/Optimizer/Builder/FIRBuilder.cpp
+++ b/flang/lib/Optimizer/Builder/FIRBuilder.cpp
@@ -1609,9 +1609,8 @@ fir::factory::getExtentFromTriplet(mlir::Value lb, mlir::Value ub,
}
mlir::Value fir::factory::genMaxWithZero(fir::FirOpBuilder &builder,
- mlir::Location loc,
- mlir::Value value) {
- mlir::Value zero = builder.createIntegerConstant(loc, value.getType(), 0);
+ mlir::Location loc, mlir::Value value,
+ mlir::Value zero) {
if (mlir::Operation *definingOp = value.getDefiningOp())
if (auto cst = mlir::dyn_cast<mlir::arith::ConstantOp>(definingOp))
if (auto intAttr = mlir::dyn_cast<mlir::IntegerAttr>(cst.getValue()))
@@ -1622,6 +1621,32 @@ mlir::Value fir::factory::genMaxWithZero(fir::FirOpBuilder &builder,
zero);
}
+mlir::Value fir::factory::genMaxWithZero(fir::FirOpBuilder &builder,
+ mlir::Location loc,
+ mlir::Value value) {
+ mlir::Value zero = builder.createIntegerConstant(loc, value.getType(), 0);
+ return genMaxWithZero(builder, loc, value, zero);
+}
+
+mlir::Value fir::factory::computeExtent(fir::FirOpBuilder &builder,
+ mlir::Location loc, mlir::Value lb,
+ mlir::Value ub, mlir::Value zero,
+ mlir::Value one) {
+ mlir::Type type = lb.getType();
+ // Let the folder deal with the common `ub - <const> + 1` case.
+ auto diff = builder.create<mlir::arith::SubIOp>(loc, type, ub, lb);
+ auto rawExtent = builder.create<mlir::arith::AddIOp>(loc, type, diff, one);
+ return fir::factory::genMaxWithZero(builder, loc, rawExtent, zero);
+}
+mlir::Value fir::factory::computeExtent(fir::FirOpBuilder &builder,
+ mlir::Location loc, mlir::Value lb,
+ mlir::Value ub) {
+ mlir::Type type = lb.getType();
+ mlir::Value one = builder.createIntegerConstant(loc, type, 1);
+ mlir::Value zero = builder.createIntegerConstant(loc, type, 0);
+ return computeExtent(builder, loc, lb, ub, zero, one);
+}
+
static std::pair<mlir::Value, mlir::Type>
genCPtrOrCFunptrFieldIndex(fir::FirOpBuilder &builder, mlir::Location loc,
mlir::Type cptrTy) {
diff --git a/flang/test/HLFIR/order_assignments/forall-pointer-assignment-scheduling-bounds.f90 b/flang/test/HLFIR/order_assignments/forall-pointer-assignment-scheduling-bounds.f90
new file mode 100644
index 0000000000000..00c94d25e7b11
--- /dev/null
+++ b/flang/test/HLFIR/order_assignments/forall-pointer-assignment-scheduling-bounds.f90
@@ -0,0 +1,93 @@
+! Test analysis of pointer assignment inside FORALL with lower bounds or bounds
+! remapping.
+! The analysis must detect if the evaluation of the LHS or RHS may be impacted
+! by the pointer assignments, or if the forall can be lowered into a single
+! loop without any temporary copy.
+
+! 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 %s 2>&1 | FileCheck %s
+! REQUIRES: asserts
+module forall_pointers_bounds
+ type ptr_wrapper
+ integer, pointer :: p(:, :)
+ end type
+contains
+
+! Simple case that can be lowered into a single loop.
+subroutine test_lb_no_conflict(a, iarray)
+ type(ptr_wrapper) :: a(:)
+ integer, target :: iarray(:, :)
+ forall(i=lbound(a,1):ubound(a,1)) a(i)%p(2*(i-1)+1:,2*i:) => iarray
+end subroutine
+
+subroutine test_remapping_no_conflict(a, iarray)
+ type(ptr_wrapper) :: a(:)
+ integer, target :: iarray(6)
+ ! Reshaping 6 to 2x3 with custom lower bounds.
+ forall(i=lbound(a,1):ubound(a,1)) a(i)%p(2*(i-1)+1:2*(i-1)+2,2*i:2*i+2) => iarray
+end subroutine
+! CHECK: ------------ scheduling forall in _QMforall_pointers_boundsPtest_remapping_no_conflict ------------
+! CHECK-NEXT: run 1 evaluate: forall/region_assign1
+
+! Bounds expression conflict. Note that even though they are syntactically on
+! the LHS,they are saved with the RHS because they are applied when preparing the
+! new descriptor value pointing to the RHS.
+subroutine test_lb_conflict(a, iarray)
+ type(ptr_wrapper) :: a(:)
+ integer, target :: iarray(:, :)
+ integer :: n
+ n = ubound(a,1)
+ forall(i=lbound(a,1):ubound(a,1)) a(i)%p(a(n+1-i)%p(1,1):,a(n+1-i)%p(2,1):) => iarray
+end subroutine
+! CHECK: ------------ scheduling forall in _QMforall_pointers_boundsPtest_lb_conflict ------------
+! CHECK-NEXT: conflict: R/W
+! CHECK-NEXT: run 1 save : forall/region_assign1/rhs
+! CHECK-NEXT: run 2 evaluate: forall/region_assign1
+
+end module
+
+! End to end test provided for debugging purpose (not run by lit).
+program end_to_end
+ use forall_pointers_bounds
+ integer, parameter :: n = 5
+ integer, target, save :: data(2, 2, n) = reshape([(i, i=1,size(data))], shape=shape(data))
+ integer, target, save :: data2(6) = reshape([(i, i=1,size(data2))], shape=shape(data2))
+ type(ptr_wrapper) :: pointers(n)
+ ! Print pointer/target mapping baseline.
+ call reset_pointers(pointers)
+ if (.not.check_equal(pointers, [17,18,19,20,13,14,15,16,9,10,11,12,5,6,7,8,1,2,3,4])) stop 1
+
+ call reset_pointers(pointers)
+ call test_lb_no_conflict(pointers, data(:, :, 1))
+ if (.not.check_equal(pointers, [([1,2,3,4],i=1,n)])) stop 2
+ if (.not.all([(lbound(pointers(i)%p), i=1,n)].eq.[(i, i=1,2*n)])) stop 3
+
+ call reset_pointers(pointers)
+ call test_remapping_no_conflict(pointers, data2)
+ if (.not.check_equal(pointers, [([1,2,3,4,5,6],i=1,n)])) stop 4
+ if (.not.all([(lbound(pointers(i)%p), i=1,n)].eq.[(i, i=1,2*n)])) stop 5
+ if (.not.all([(ubound(pointers(i)%p), i=1,n)].eq.[([2*(i-1)+2, 2*i+2], i=1,n)])) stop 6
+
+ call reset_pointers(pointers)
+ call test_lb_conflict(pointers, data(:, :, 1))
+ if (.not.check_equal(pointers, [([1,2,3,4],i=1,n)])) stop 7
+ if (.not.all([(lbound(pointers(i)%p), i=1,n)].eq.[([data(1,1,i), data(2,1,i)], i=1,n)])) stop 8
+
+ print *, "PASS"
+contains
+subroutine reset_pointers(a)
+ type(ptr_wrapper) :: a(:)
+ do i=1,n
+ a(i)%p => data(:, :, n+1-i)
+ end do
+end subroutine
+logical function check_equal(a, expected)
+ type(ptr_wrapper) :: a(:)
+ integer :: expected(:)
+ check_equal = all([(a(i)%p, i=1,n)].eq.expected)
+ if (.not.check_equal) then
+ print *, "expected:", expected
+ print *, "got:", [(a(i)%p, i=1,n)]
+ end if
+end function
+end
diff --git a/flang/test/HLFIR/order_assignments/forall-pointer-assignment-scheduling-polymorphic.f90 b/flang/test/HLFIR/order_assignments/forall-pointer-assignment-scheduling-polymorphic.f90
new file mode 100644
index 0000000000000..9ccba7acc1b08
--- /dev/null
+++ b/flang/test/HLFIR/order_assignments/forall-pointer-assignment-scheduling-polymorphic.f90
@@ -0,0 +1,110 @@
+! Test analysis of polymorphic pointer assignment inside FORALL.
+! The analysis must detect if the evaluation of the LHS or RHS may be impacted
+! by the pointer assignments, or if the forall can be lowered into a single
+! loop without any temporary copy.
+
+! 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 %s 2>&1 | FileCheck %s
+! REQUIRES: asserts
+module forall_poly_pointers
+ type base
+ integer :: i
+ end type
+ type, extends(base) :: extension
+ integer :: j
+ end type
+ type ptr_wrapper
+ class(base), pointer :: p
+ end type
+contains
+
+! Simple case that can be lowered into a single loop.
+subroutine test_no_conflict(n, a, somet)
+ integer :: n
+ type(ptr_wrapper) :: a(:)
+ class(base), target :: somet
+ forall(i=1:n) a(i)%p => somet
+end subroutine
+! CHECK: ------------ scheduling forall in _QMforall_poly_pointersPtest_no_conflict ------------
+! CHECK-NEXT: run 1 evaluate: forall/region_assign1
+
+subroutine test_no_conflict2(n, a, somet)
+ integer :: n
+ type(ptr_wrapper) :: a(:)
+ type(base), target :: somet
+ forall(i=1:n) a(i)%p => somet
+end subroutine
+! CHECK: ------------ scheduling forall in _QMforall_poly_pointersPtest_no_conflict2 ------------
+! CHECK-NEXT: run 1 evaluate: forall/region_assign1
+
+subroutine test_rhs_conflict(n, a)
+ integer :: n
+ type(ptr_wrapper) :: a(:)
+ forall(i=1:n) a(i)%p => a(n+1-i)%p
+end subroutine
+! CHECK: ------------ scheduling forall in _QMforall_poly_pointersPtest_rhs_conflict ------------
+! CHECK-NEXT: conflict: R/W
+! CHECK-NEXT: run 1 save : forall/region_assign1/rhs
+! CHECK-NEXT: run 2 evaluate: forall/region_assign1
+end module
+
+! End to end test provided for debugging purpose (not run by lit).
+program end_to_end
+ use forall_poly_pointers
+ integer, parameter :: n = 10
+ type(extension), target, save :: data(n) = [(extension(i, 100+i), i=1,n)]
+ type(ptr_wrapper) :: pointers(n)
+ ! Print pointer/target mapping baseline.
+ call reset_pointers(pointers)
+ if (.not.check_equal(pointers, [10,9,8,7,6,5,4,3,2,1])) stop 1
+ if (.not.check_type(pointers, [(modulo(i,3).eq.0, i=1,n)])) stop 2
+
+ ! Test dynamic type is correctly set.
+ call test_no_conflict(n, pointers, data(1))
+ if (.not.check_equal(pointers, [(1,i=1,10)])) stop 3
+ if (.not.check_type(pointers, [(.true.,i=1,10)])) stop 4
+ call test_no_conflict(n, pointers, data(1)%base)
+ if (.not.check_equal(pointers, [(1,i=1,10)])) stop 5
+ if (.not.check_type(pointers, [(.false.,i=1,10)])) stop 6
+
+ call test_no_conflict2(n, pointers, data(1)%base)
+ if (.not.check_equal(pointers, [(1,i=1,10)])) stop 7
+ if (.not.check_type(pointers, [(.false.,i=1,10)])) stop 8
+
+ ! Test RHS conflict.
+ call reset_pointers(pointers)
+ call test_rhs_conflict(n, pointers)
+ if (.not.check_equal(pointers, [(i, i=1,10)])) stop 9
+ if (.not.check_type(pointers, [(modulo(i,3).eq.2, i=1,n)])) stop 10
+
+ print *, "PASS"
+contains
+subroutine reset_pointers(a)
+ type(ptr_wrapper) :: a(:)
+ do i=1,n
+ if (modulo(i,3).eq.0) then
+ a(i)%p => data(n+1-i)
+ else
+ a(i)%p => data(n+1-i)%base
+ end if
+ end do
+end subroutine
+logical function check_equal(a, expected)
+ type(ptr_wrapper) :: a(:)
+ integer :: expected(:)
+ check_equal = all([(a(i)%p%i, i=1,10)].eq.expected)
+ if (.not.check_equal) then
+ print *, "expected:", expected
+ print *, "got:", [(a(i)%p%i, i=1,10)]
+ end if
+end function
+logical function check_type(a, expected)
+ type(ptr_wrapper) :: a(:)
+ logical :: expected(:)
+ check_type = all([(same_type_as(a(i)%p, extension(1,1)), i=1,10)].eqv.expected)
+ if (.not.check_type) then
+ print *, "expected:", expected
+ print *, "got:", [(same_type_as(a(i)%p, extension(1,1)), i=1,10)]
+ end if
+end function
+end
diff --git a/flang/test/HLFIR/order_assignments/forall-pointer-assignment-scheduling.f90 b/flang/test/HLFIR/order_assignments/forall-pointer-assignment-scheduling.f90
index 52a0105ce2b6a..cb5bff1020b3a 100644
--- a/flang/test/HLFIR/order_assignments/forall-pointer-assignment-scheduling.f90
+++ b/flang/test/HLFIR/order_assignments/forall-pointer-assignment-scheduling.f90
@@ -25,6 +25,14 @@ subroutine test_no_conflict(n, a, somet)
! CHECK: ------------ scheduling forall in _QMforall_pointersPtest_no_conflict ------------
! CHECK-NEXT: run 1 evaluate: forall/region_assign1
+subroutine test_null_no_conflict(n, a)
+ integer :: n
+ type(ptr_wrapper), allocatable :: a(:)
+ forall(i=1:n) a(i)%p => null()
+end subroutine
+! CHECK: ------------ scheduling forall in _QMforall_pointersPtest_null_no_conflict ------------
+! CHECK-NEXT: run 1 evaluate: forall/region_assign1
+
! Case where the pointer target evaluations are impacted by the pointer
! assignments and should be evaluated for each iteration before doing
! any pointer assignment.
@@ -53,6 +61,16 @@ subroutine test_need_to_save_lhs(n, a, somet)
! CHECK-NEXT: run 1 save : forall/region_assign1/lhs
! CHECK-NEXT: run 2 evaluate: forall/region_assign1
+subroutine test_null_need_to_save_lhs(n, a)
+ integer :: n
+ type(ptr_wrapper) :: a(:)
+ forall(i=1:n) a(a(n+1-i)%p%i)%p => null()
+end subroutine
+! CHECK: ------------ scheduling forall in _QMforall_pointersPtest_null_need_to_save_lhs ------------
+! CHECK-NEXT: conflict: R/W
+! CHECK-NEXT: run 1 save : forall/region_assign1/lhs
+! CHECK-NEXT: run 2 evaluate: forall/region_assign1
+
! Case where both the computation of the target and descriptor addresses are
! impacted by the assignment and need to be all evaluated before doing any
! assignment.
@@ -76,27 +94,29 @@ program end_to_end
type(t), target, save :: data(n) = [(t(i), i=1,n)]
type(ptr_wrapper) :: pointers(n)
! Print pointer/target mapping baseline.
- ! Expect: 10 9 8 7 6 5 4 3 2 1
call reset_pointers(pointers)
- call print_pointers(pointers)
+ if (.not.check_equal(pointers, [10,9,8,7,6,5,4,3,2,1])) stop 1
! Test case where RHS target addresses must be saved in FORALL.
- ! Expect: 1 2 3 4 5 6 7 8 9 10
call test_need_to_save_rhs(n, pointers)
- call print_pointers(pointers)
+ if (.not.check_equal(pointers, [1,2,3,4,5,6,7,8,9,10])) stop 2
! Test case where LHS pointer addresses must be saved in FORALL.
- ! Expect: 1 1 1 1 1 1 1 1 1 1
call reset_pointers(pointers)
call test_need_to_save_lhs(n, pointers, data(1))
- call print_pointers(pointers)
+ if (.not.check_equal(pointers, [(1,i=1,10)])) stop 3
! Test case where bot RHS target addresses and LHS pointer addresses must be
! saved in FORALL.
- ! Expect: 2 4 6 8 10 1 3 5 7 9
call reset_pointers(pointers)
call test_need_to_save_lhs_and_rhs(n, pointers)
- call print_pointers(pointers)
+ if (.not.check_equal(pointers, [2,4,6,8,10,1,3,5,7,9])) stop 4
+
+ call reset_pointers(pointers)
+ call test_null_need_to_save_lhs(n, pointers)
+ if (.not.check_associated(pointers, [(.false., i=1,n)])) stop 5
+
+ print *, "PASS"
contains
subroutine reset_pointers(a)
type(ptr_wrapper) :: a(:)
@@ -104,8 +124,22 @@ subroutine reset_pointers(a)
a(i)%p => data(n+1-i)
end do
end subroutine
-subroutine print_pointers(a)
+logical function check_equal(a, expected)
type(ptr_wrapper) :: a(:)
- print *, [(a(i)%p%i, i=lbound(a,1), ubound(a,1))]
-end subroutine
+ integer :: expected(:)
+ check_equal = all([(a(i)%p%i, i=1,10)].eq.expected)
+ if (.not.check_equal) then
+ print *, "expected:", expected
+ print *, "got:", [(a(i)%p%i, i=1,10)]
+ end if
+end function
+logical function check_associated(a, expected)
+ type(ptr_wrapper) :: a(:)
+ logical :: expected(:)
+ check_associated = all([(associated(a(i)%p), i=1,10)].eqv.expected)
+ if (.not.check_associated) then
+ print *, "expected:", expected
+ print *, "got:", [(associated(a(i)%p), i=1,10)]
+ end if
+end function
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
index ba9c203453d95..0cce790470cb4 100644
--- a/flang/test/HLFIR/order_assignments/forall-proc-pointer-assignment-scheduling.f90
+++ b/flang/test/HLFIR/order_assignments/forall-proc-pointer-assignment-scheduling.f90
@@ -80,6 +80,23 @@ subroutine test_need_to_save_lhs_and_rhs(x)
! CHECK-NEXT: run 1 save : forall/region_assign1/lhs
! CHECK-NEXT: run 2 evaluate: forall/region_assign1
+ subroutine test_null_no_conflict(x)
+ type(t) :: x(10)
+ forall(i=1:10) x(i)%p => null()
+ end subroutine
+! CHECK: ------------ scheduling forall in _QMproc_ptr_forallPtest_null_no_conflict ------------
+! CHECK-NEXT: run 1 evaluate: forall/region_assign1
+
+ subroutine test_null_need_to_save_lhs(x)
+ type(t) :: x(10)
+ forall(i=1:10) x(x(11-i)%p())%p => null()
+ end subroutine
+! CHECK: ------------ scheduling forall in _QMproc_ptr_forallPtest_null_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
! End-to-end test utilities for debugging purposes.
@@ -102,6 +119,17 @@ logical function check_equal(a, expected)
print *, "got:", [(a(i)%p(), i=1,10)]
end if
end function
+
+ logical function check_association(a, expected)
+ type(t) :: a(:)
+ logical :: expected(:)
+ check_association = all([(associated(a(i)%p), i=1,10)].eqv.expected)
+ if (.not.check_association) then
+ print *, "expected:", expected
+ print *, "got:", [(associated(a(i)%p), i=1,10)]
+ end if
+ end function
+
end module
! End-to-end test for debugging purposes (not verified by lit).
@@ -119,5 +147,10 @@ logical function check_equal(a, expected)
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
+
+ call reset(a)
+ call test_null_need_to_save_lhs(a)
+ if (.not.check_association(a, [(.false., i=1,10)])) stop 4
+
print *, "PASS"
end
diff --git a/flang/test/Lower/OpenACC/acc-enter-data-unwrap-defaultbounds.f90 b/flang/test/Lower/OpenACC/acc-enter-data-unwrap-defaultbounds.f90
index 6bdd1031eeb4e..b6d76134f14af 100644
--- a/flang/test/Lower/OpenACC/acc-enter-data-unwrap-defaultbounds.f90
+++ b/flang/test/Lower/OpenACC/acc-enter-data-unwrap-defaultbounds.f90
@@ -203,10 +203,10 @@ subroutine acc_enter_data_dummy(a, b, n, m)
!CHECK: %[[LOAD_M:.*]] = fir.load %[[DECLM]]#0 : !fir.ref<i32>
!CHECK: %[[M_I64:.*]] = fir.convert %[[LOAD_M]] : (i32) -> i64
!CHECK: %[[M_IDX:.*]] = fir.convert %[[M_I64]] : (i64) -> index
-!CHECK: %[[M_N:.*]] = arith.subi %[[M_IDX]], %[[N_IDX]] : index
!CHECK: %[[C1:.*]] = arith.constant 1 : index
-!CHECK: %[[M_N_1:.*]] = arith.addi %[[M_N]], %[[C1]] : index
!CHECK: %[[C0:.*]] = arith.constant 0 : index
+!CHECK: %[[M_N:.*]] = arith.subi %[[M_IDX]], %[[N_IDX]] : index
+!CHECK: %[[M_N_1:.*]] = arith.addi %[[M_N]], %[[C1]] : index
!CHECK: %[[CMP:.*]] = arith.cmpi sgt, %[[M_N_1]], %[[C0]] : index
!CHECK: %[[EXT_B:.*]] = arith.select %[[CMP]], %[[M_N_1]], %[[C0]] : index
!CHECK: %[[DECLB:.*]]:2 = hlfir.declare %[[B]]
diff --git a/flang/test/Lower/OpenACC/acc-enter-data.f90 b/flang/test/Lower/OpenACC/acc-enter-data.f90
index 8892dec7d1197..2b7cda468f70f 100644
--- a/flang/test/Lower/OpenACC/acc-enter-data.f90
+++ b/flang/test/Lower/OpenACC/acc-enter-data.f90
@@ -147,10 +147,10 @@ subroutine acc_enter_data_dummy(a, b, n, m)
!CHECK: %[[LOAD_M:.*]] = fir.load %[[DECLM]]#0 : !fir.ref<i32>
!CHECK: %[[M_I64:.*]] = fir.convert %[[LOAD_M]] : (i32) -> i64
!CHECK: %[[M_IDX:.*]] = fir.convert %[[M_I64]] : (i64) -> index
-!CHECK: %[[M_N:.*]] = arith.subi %[[M_IDX]], %[[N_IDX]] : index
!CHECK: %[[C1:.*]] = arith.constant 1 : index
-!CHECK: %[[M_N_1:.*]] = arith.addi %[[M_N]], %[[C1]] : index
!CHECK: %[[C0:.*]] = arith.constant 0 : index
+!CHECK: %[[M_N:.*]] = arith.subi %[[M_IDX]], %[[N_IDX]] : index
+!CHECK: %[[M_N_1:.*]] = arith.addi %[[M_N]], %[[C1]] : index
!CHECK: %[[CMP:.*]] = arith.cmpi sgt, %[[M_N_1]], %[[C0]] : index
!CHECK: %[[EXT_B:.*]] = arith.select %[[CMP]], %[[M_N_1]], %[[C0]] : index
!CHECK: %[[DECLB:.*]]:2 = hlfir.declare %[[B]]
>From e49719fbe44c11f0b1737cf315c7db2bb1beb668 Mon Sep 17 00:00:00 2001
From: jeanPerier <jean.perier.polytechnique at gmail.com>
Date: Thu, 13 Mar 2025 10:11:45 +0100
Subject: [PATCH 2/2] Removed unused variable.
---
flang/lib/Lower/Bridge.cpp | 3 +--
1 file changed, 1 insertion(+), 2 deletions(-)
diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp
index d0b26ddc92133..feab1b7f0a8dc 100644
--- a/flang/lib/Lower/Bridge.cpp
+++ b/flang/lib/Lower/Bridge.cpp
@@ -4417,8 +4417,7 @@ class FirConverter : public Fortran::lower::AbstractConverter {
rhs = hlfir::Entity{builder->create<fir::LoadOp>(loc, rhs)};
mlir::Value rhsBox = hlfir::genVariableBox(
loc, *builder, rhs, lhsBoxType.getBoxTypeWithNewShape(rhs.getRank()));
- mlir::Type indexTy = builder->getIndexType();
- // Bounds
+ // Apply lower bounds or reshaping if any.
if (const auto *lbExprs =
std::get_if<Fortran::evaluate::Assignment::BoundsSpec>(&assign.u);
lbExprs && !lbExprs->empty()) {
More information about the flang-commits
mailing list