diff --git a/flang/include/flang/Lower/Runtime.h b/flang/include/flang/Lower/Runtime.h index e4f8954727203..e71496edad9ba 100644 --- a/flang/include/flang/Lower/Runtime.h +++ b/flang/include/flang/Lower/Runtime.h @@ -68,6 +68,9 @@ void genPointerAssociate(fir::FirOpBuilder &, mlir::Location, void genPointerAssociateRemapping(fir::FirOpBuilder &, mlir::Location, mlir::Value pointer, mlir::Value target, mlir::Value bounds); +void genPointerAssociateLowerBounds(fir::FirOpBuilder &, mlir::Location, + mlir::Value pointer, mlir::Value target, + mlir::Value lbounds); } // namespace lower } // namespace Fortran diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp index f6745a458f6f6..c0a5aa3c394ca 100644 --- a/flang/lib/Lower/Bridge.cpp +++ b/flang/lib/Lower/Bridge.cpp @@ -54,6 +54,7 @@ #include "mlir/IR/PatternMatch.h" #include "mlir/Parser/Parser.h" #include "mlir/Transforms/RegionUtils.h" +#include "llvm/ADT/SmallVector.h" #include "llvm/ADT/StringSet.h" #include "llvm/Support/CommandLine.h" #include "llvm/Support/Debug.h" @@ -2589,6 +2590,30 @@ class FirConverter : public Fortran::lower::AbstractConverter { return Fortran::lower::createMutableBox(loc, *this, expr, localSymbols); } + // Create the [newRank] array with the lower bounds to be passed to the + // runtime as a descriptor. + mlir::Value createLboundArray(llvm::ArrayRef lbounds, + mlir::Location loc) { + mlir::Type indexTy = builder->getIndexType(); + mlir::Type boundArrayTy = fir::SequenceType::get( + {static_cast(lbounds.size())}, builder->getI64Type()); + mlir::Value boundArray = builder->create(loc, boundArrayTy); + mlir::Value array = builder->create(loc, boundArrayTy); + for (unsigned i = 0; i < lbounds.size(); ++i) { + array = builder->create( + loc, boundArrayTy, array, lbounds[i], + builder->getArrayAttr({builder->getIntegerAttr( + builder->getIndexType(), static_cast(i))})); + } + builder->create(loc, array, boundArray); + mlir::Type boxTy = fir::BoxType::get(boundArrayTy); + mlir::Value ext = + builder->createIntegerConstant(loc, indexTy, lbounds.size()); + llvm::SmallVector shapes = {ext}; + mlir::Value shapeOp = builder->genShape(loc, shapes); + return builder->create(loc, boxTy, boundArray, shapeOp); + } + // Generate pointer assignment with possibly empty bounds-spec. R1035: a // bounds-spec is a lower bound value. void genPointerAssignment( @@ -2606,8 +2631,18 @@ class FirConverter : public Fortran::lower::AbstractConverter { if (lhsType && lhsType->IsPolymorphic()) { if (!lowerToHighLevelFIR() && explicitIterationSpace()) TODO(loc, "polymorphic pointer assignment in FORALL"); + llvm::SmallVector lbounds; + for (const Fortran::evaluate::ExtentExpr &lbExpr : lbExprs) + lbounds.push_back( + fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx))); mlir::Value lhs = genExprMutableBox(loc, assign.lhs).getAddr(); mlir::Value rhs = fir::getBase(genExprBox(loc, assign.rhs, stmtCtx)); + if (!lbounds.empty()) { + mlir::Value boundsDesc = createLboundArray(lbounds, loc); + Fortran::lower::genPointerAssociateLowerBounds(*builder, loc, lhs, rhs, + boundsDesc); + return; + } Fortran::lower::genPointerAssociate(*builder, loc, lhs, rhs); return; } diff --git a/flang/lib/Lower/Runtime.cpp b/flang/lib/Lower/Runtime.cpp index d490264874c08..54c3a4e95d710 100644 --- a/flang/lib/Lower/Runtime.cpp +++ b/flang/lib/Lower/Runtime.cpp @@ -205,3 +205,16 @@ void Fortran::lower::genPointerAssociateRemapping(fir::FirOpBuilder &builder, sourceLine); builder.create(loc, func, args).getResult(0); } + +void Fortran::lower::genPointerAssociateLowerBounds(fir::FirOpBuilder &builder, + mlir::Location loc, + mlir::Value pointer, + mlir::Value target, + mlir::Value lbounds) { + mlir::func::FuncOp func = + fir::runtime::getRuntimeFunc( + loc, builder); + llvm::SmallVector args = fir::runtime::createArguments( + builder, loc, func.getFunctionType(), pointer, target, lbounds); + builder.create(loc, func, args).getResult(0); +} diff --git a/flang/test/Lower/polymorphic.f90 b/flang/test/Lower/polymorphic.f90 index 3e9a951e2528b..dd2c616bbd00f 100644 --- a/flang/test/Lower/polymorphic.f90 +++ b/flang/test/Lower/polymorphic.f90 @@ -434,6 +434,30 @@ subroutine pointer_assign_remap() ! CHECK: %[[ARG2:.*]] = fir.convert %[[BOXED_BOUND_ARRAY]] : (!fir.box>) -> !fir.box ! CHECK: %{{.*}} = fir.call @_FortranAPointerAssociateRemapping(%[[ARG0]], %[[ARG1]], %[[ARG2]], %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref>, !fir.box, !fir.box, !fir.ref, i32) -> none + subroutine pointer_assign_lower_bounds() + class(p1), allocatable, target :: a(:) + class(p1), pointer :: p(:) + allocate(a(100)) + p(-50:) => a + end subroutine + +! CHECK-LABEL: func.func @_QMpolymorphic_testPpointer_assign_lower_bounds() { +! CHECK: %[[A:.*]] = fir.alloca !fir.class>>> {bindc_name = "a", fir.target, uniq_name = "_QMpolymorphic_testFpointer_assign_lower_boundsEa"} +! CHECK: %[[P:.*]] = fir.alloca !fir.class>>> {bindc_name = "p", uniq_name = "_QMpolymorphic_testFpointer_assign_lower_boundsEp"} +! CHECK: %[[LB:.*]] = arith.constant -50 : i64 +! CHECK: %[[REBOX_A:.*]] = fir.rebox %21(%23) : (!fir.class>>>, !fir.shift<1>) -> !fir.class>> +! CHECK: %[[LBOUND_ARRAY:.*]] = fir.alloca !fir.array<1xi64> +! CHECK: %[[ARRAY:.*]] = fir.undefined !fir.array<1xi64> +! CHECK: %[[ARRAY0:.*]] = fir.insert_value %[[ARRAY]], %[[LB]], [0 : index] : (!fir.array<1xi64>, i64) -> !fir.array<1xi64> +! CHECK: fir.store %[[ARRAY0]] to %[[LBOUND_ARRAY]] : !fir.ref> +! CHECK: %[[C1:.*]] = arith.constant 1 : index +! CHECK: %[[LBOUND_ARRAY_SHAPE:.*]] = fir.shape %[[C1]] : (index) -> !fir.shape<1> +! CHECK: %[[LBOUND_ARRAY_BOXED:.*]] = fir.embox %[[LBOUND_ARRAY]](%[[LBOUND_ARRAY_SHAPE]]) : (!fir.ref>, !fir.shape<1>) -> !fir.box> +! CHECK: %[[P_BOX_NONE:.*]] = fir.convert %[[P]] : (!fir.ref>>>>) -> !fir.ref> +! CHECK: %[[A_BOX_NONE:.*]] = fir.convert %[[REBOX_A]] : (!fir.class>>) -> !fir.box +! CHECK: %[[LBOUNDS_BOX_NONE:.*]] = fir.convert %[[LBOUND_ARRAY_BOXED]] : (!fir.box>) -> !fir.box +! CHECK: %{{.*}} = fir.call @_FortranAPointerAssociateLowerBounds(%[[P_BOX_NONE]], %[[A_BOX_NONE]], %[[LBOUNDS_BOX_NONE]]) {{.*}} : (!fir.ref>, !fir.box, !fir.box) -> none + subroutine test_elemental_assign() type(p1) :: pa(3) pa = [ 1, 2, 3 ]