diff --git a/flang/include/flang/Lower/Runtime.h b/flang/include/flang/Lower/Runtime.h --- a/flang/include/flang/Lower/Runtime.h +++ b/flang/include/flang/Lower/Runtime.h @@ -71,6 +71,9 @@ void genPointerAssociate(fir::FirOpBuilder &, mlir::Location, mlir::Value pointer, mlir::Value target); +void genPointerAssociateRemapping(fir::FirOpBuilder &, mlir::Location, + mlir::Value pointer, mlir::Value target, + mlir::Value bounds); mlir::Value genCpuTime(fir::FirOpBuilder &, mlir::Location); void genDateAndTime(fir::FirOpBuilder &, mlir::Location, diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp --- a/flang/lib/Lower/Bridge.cpp +++ b/flang/lib/Lower/Bridge.cpp @@ -2763,15 +2763,6 @@ // bounds-remapping is a pair, lower bound and upper bound. [&](const Fortran::evaluate::Assignment::BoundsRemapping &boundExprs) { - std::optional lhsType = - assign.lhs.GetType(); - std::optional rhsType = - assign.rhs.GetType(); - // Polymorphic lhs/rhs may need more care. See F2018 10.2.2.3. - if ((lhsType && lhsType->IsPolymorphic()) || - (rhsType && rhsType->IsPolymorphic())) - TODO(loc, "pointer assignment involving polymorphic entity"); - llvm::SmallVector lbounds; llvm::SmallVector ubounds; for (const std::pair lhsType = + assign.lhs.GetType(); + std::optional rhsType = + assign.rhs.GetType(); + // Polymorphic lhs/rhs may need more care. See F2018 10.2.2.3. + if ((lhsType && lhsType->IsPolymorphic()) || + (rhsType && rhsType->IsPolymorphic())) { + mlir::Value lhs = genExprMutableBox(loc, assign.lhs).getAddr(); + mlir::Value rhs = + fir::getBase(genExprBox(loc, assign.rhs, stmtCtx)); + + // Create the 2xnewRank array with the bounds to be passed to + // the runtime as a descriptor. + assert(lbounds.size() && ubounds.size()); + fir::SequenceType::Shape shape(2, lbounds.size()); + mlir::Type indexTy = builder->getIndexType(); + mlir::Type boundArrayTy = + fir::SequenceType::get(shape, builder->getI64Type()); + mlir::Value boundArray = + builder->create(loc, boundArrayTy); + mlir::Value array = + builder->create(loc, boundArrayTy); + llvm::SmallVector exts; + mlir::Value c2 = + builder->createIntegerConstant(loc, indexTy, 2); + 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->getIntegerAttr(builder->getIndexType(), + static_cast(0))})); + array = builder->create( + loc, boundArrayTy, array, ubounds[i], + builder->getArrayAttr( + {builder->getIntegerAttr(builder->getIndexType(), + static_cast(i)), + builder->getIntegerAttr(builder->getIndexType(), + static_cast(1))})); + exts.push_back(c2); + } + builder->create(loc, array, boundArray); + mlir::Type boxTy = fir::BoxType::get(boundArrayTy); + mlir::Value shapeOp = builder->genShape(loc, exts); + mlir::Value boundsDesc = builder->create( + loc, boxTy, boundArray, shapeOp); + Fortran::lower::genPointerAssociateRemapping(*builder, loc, lhs, + rhs, boundsDesc); + return; + } if (explicitIterationSpace()) { // Pointer assignment in FORALL context. Copy the rhs box value // into the lhs box variable. diff --git a/flang/lib/Lower/Runtime.cpp b/flang/lib/Lower/Runtime.cpp --- a/flang/lib/Lower/Runtime.cpp +++ b/flang/lib/Lower/Runtime.cpp @@ -199,6 +199,24 @@ builder.create(loc, func, args).getResult(0); } +void Fortran::lower::genPointerAssociateRemapping(fir::FirOpBuilder &builder, + mlir::Location loc, + mlir::Value pointer, + mlir::Value target, + mlir::Value bounds) { + mlir::func::FuncOp func = + fir::runtime::getRuntimeFunc(loc, + builder); + auto fTy = func.getFunctionType(); + auto sourceFile = fir::factory::locationToFilename(builder, loc); + auto sourceLine = + fir::factory::locationToLineNo(builder, loc, fTy.getInput(4)); + llvm::SmallVector args = fir::runtime::createArguments( + builder, loc, func.getFunctionType(), pointer, target, bounds, sourceFile, + sourceLine); + builder.create(loc, func, args).getResult(0); +} + mlir::Value Fortran::lower::genCpuTime(fir::FirOpBuilder &builder, mlir::Location loc) { mlir::func::FuncOp func = diff --git a/flang/test/Lower/polymorphic.f90 b/flang/test/Lower/polymorphic.f90 --- a/flang/test/Lower/polymorphic.f90 +++ b/flang/test/Lower/polymorphic.f90 @@ -301,4 +301,35 @@ ! CHECK: %[[UP:.*]] = fir.convert %[[BOX_COMPLEX]] : (!fir.class>) -> !fir.class ! CHECK: fir.call @_QMpolymorphic_testPup_input(%[[UP]]) {{.*}} : (!fir.class) -> () + subroutine pointer_assign_remap() + class(p1), pointer :: a(:) + class(p1), pointer :: p(:,:) + allocate(a(100)) + p(1:10,1:10) => a + end subroutine + +! CHECK-LABEL: func.func @_QMpolymorphic_testPpointer_assign_remap() { +! CHECK: %[[A:.*]] = fir.alloca !fir.class>>> {bindc_name = "a", uniq_name = "_QMpolymorphic_testFpointer_assign_remapEa"} +! CHECK: %[[P:.*]] = fir.alloca !fir.class>>> {bindc_name = "p", uniq_name = "_QMpolymorphic_testFpointer_assign_remapEp"} +! CHECK: %[[C1_0:.*]] = arith.constant 1 : i64 +! CHECK: %[[C10_0:.*]] = arith.constant 10 : i64 +! CHECK: %[[C1_1:.*]] = arith.constant 1 : i64 +! CHECK: %[[C10_1:.*]] = arith.constant 10 : i64 +! CHECK: %[[LOAD_A:.*]] = fir.load %[[A]] : !fir.ref>>>> +! CHECK: %[[REBOX_A:.*]] = fir.rebox %[[LOAD_A]](%{{.*}}) : (!fir.class>>>, !fir.shift<1>) -> !fir.class>> +! CHECK: %[[BOUND_ARRAY:.*]] = fir.alloca !fir.array<2x2xi64> +! CHECK: %[[ARRAY:.*]] = fir.undefined !fir.array<2x2xi64> +! CHECK: %[[C2:.*]] = arith.constant 2 : index +! CHECK: %[[ARRAY0:.*]] = fir.insert_value %[[ARRAY]], %[[C1_0]], [0 : index, 0 : index] : (!fir.array<2x2xi64>, i64) -> !fir.array<2x2xi64> +! CHECK: %[[ARRAY1:.*]] = fir.insert_value %[[ARRAY0]], %[[C10_0]], [0 : index, 1 : index] : (!fir.array<2x2xi64>, i64) -> !fir.array<2x2xi64> +! CHECK: %[[ARRAY2:.*]] = fir.insert_value %[[ARRAY1]], %[[C1_1]], [1 : index, 0 : index] : (!fir.array<2x2xi64>, i64) -> !fir.array<2x2xi64> +! CHECK: %[[ARRAY3:.*]] = fir.insert_value %[[ARRAY2]], %[[C10_1]], [1 : index, 1 : index] : (!fir.array<2x2xi64>, i64) -> !fir.array<2x2xi64> +! CHECK: fir.store %[[ARRAY3]] to %[[BOUND_ARRAY]] : !fir.ref> +! CHECK: %[[BOUND_ARRAY_SHAPE:.*]] = fir.shape %[[C2]], %[[C2]] : (index, index) -> !fir.shape<2> +! CHECK: %[[BOXED_BOUND_ARRAY:.*]] = fir.embox %[[BOUND_ARRAY]](%[[BOUND_ARRAY_SHAPE]]) : (!fir.ref>, !fir.shape<2>) -> !fir.box> +! CHECK: %[[ARG0:.*]] = fir.convert %[[P]] : (!fir.ref>>>>) -> !fir.ref> +! CHECK: %[[ARG1:.*]] = fir.convert %[[REBOX_A]] : (!fir.class>>) -> !fir.box +! CHECK: %[[ARG2:.*]] = fir.convert %[[BOXED_BOUND_ARRAY]] : (!fir.box>) -> !fir.box +! CHECK: %{{.*}} = fir.call @_FortranAPointerAssociateRemapping(%[[ARG0]], %[[ARG1]], %[[ARG2]], %{{.*}}, %{{.*}}) fastmath : (!fir.ref>, !fir.box, !fir.box, !fir.ref, i32) -> none + end module