shylie/llvm-project
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

[flang] lower remaining cases of pointer assignments inside forall (#130772)

Browse Source 
Implement handling of `NULL()` RHS, polymorphic pointers, as well as
lower bounds or bounds remapping in pointer assignment inside FORALL.

These cases eventually do not require updating hlfir.region_assign,
lowering can simply prepare the new descriptor for the LHS inside the
RHS region.

Looking more closely at the polymorphic cases, there is not need to call
the runtime, fir.rebox and fir.embox do handle the dynamic type setting
correctly.

After this patch, the last remaining TODO is the allocatable assignment
inside FORALL, which like some cases here, is more likely an accidental
feature given FORALL was deprecated in F2003 at the same time than
allocatable components where added.
This commit is contained in:
jeanPerier 2025-03-14 10:51:46 +01:00 committed by GitHub
parent 7bae61370d
commit 3ff3b29dd6
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
10 changed files with 392 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
flang/include/flang/Optimizer/Builder/FIRBuilder.h
View File

@ -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

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

@ -4353,30 +4353,12 @@ private:
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,73 @@ private:
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()));
// Apply lower bounds or reshaping if any.
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 +4889,16 @@ private:
},
[&](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);

18
flang/lib/Lower/ConvertVariable.cpp
View File

@ -1577,17 +1577,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(
@ -1651,8 +1640,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));
}
@ -2272,7 +2261,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");

31
flang/lib/Optimizer/Builder/FIRBuilder.cpp
View File

@ -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) {

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

@ -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

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

@ -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

56
flang/test/HLFIR/order_assignments/forall-pointer-assignment-scheduling.f90
View File

@ -25,6 +25,14 @@ end subroutine
! 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 @@ end subroutine
! 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

33
flang/test/HLFIR/order_assignments/forall-proc-pointer-assignment-scheduling.f90
View File

@ -80,6 +80,23 @@ contains
! 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 @@ contains
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 @@ end module
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

4
flang/test/Lower/OpenACC/acc-enter-data-unwrap-defaultbounds.f90
View File

@ -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]]

4
flang/test/Lower/OpenACC/acc-enter-data.f90
View File

@ -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]]