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
#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"
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<mlir::Value> lbounds,
+ mlir::Location loc) {
+ mlir::Type indexTy = builder->getIndexType();
+ mlir::Type boundArrayTy = fir::SequenceType::get(
+ {static_cast<int64_t>(lbounds.size())}, builder->getI64Type());
+ mlir::Value boundArray = builder->create<fir::AllocaOp>(loc, boundArrayTy);
+ mlir::Value array = builder->create<fir::UndefOp>(loc, boundArrayTy);
+ for (unsigned i = 0; i < lbounds.size(); ++i) {
+ array = builder->create<fir::InsertValueOp>(
+ loc, boundArrayTy, array, lbounds[i],
+ builder->getArrayAttr({builder->getIntegerAttr(
+ builder->getIndexType(), static_cast<int>(i))}));
+ }
+ builder->create<fir::StoreOp>(loc, array, boundArray);
+ mlir::Type boxTy = fir::BoxType::get(boundArrayTy);
+ mlir::Value ext =
+ builder->createIntegerConstant(loc, indexTy, lbounds.size());
+ llvm::SmallVector<mlir::Value> shapes = {ext};
+ mlir::Value shapeOp = builder->genShape(loc, shapes);
+ return builder->create<fir::EmboxOp>(loc, boxTy, boundArray, shapeOp);
+ }
+
// Generate pointer assignment with possibly empty bounds-spec. R1035: a
// bounds-spec is a lower bound value.
void genPointerAssignment(
if (lhsType && lhsType->IsPolymorphic()) {
if (!lowerToHighLevelFIR() && explicitIterationSpace())
TODO(loc, "polymorphic pointer assignment in FORALL");
+ llvm::SmallVector<mlir::Value> 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;
}
sourceLine);
builder.create<fir::CallOp>(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<mkRTKey(PointerAssociateLowerBounds)>(
+ loc, builder);
+ llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
+ builder, loc, func.getFunctionType(), pointer, target, lbounds);
+ builder.create<fir::CallOp>(loc, func, args).getResult(0);
+}
! CHECK: %[[ARG2:.*]] = fir.convert %[[BOXED_BOUND_ARRAY]] : (!fir.box<!fir.array<2x1xi64>>) -> !fir.box<none>
! CHECK: %{{.*}} = fir.call @_FortranAPointerAssociateRemapping(%[[ARG0]], %[[ARG1]], %[[ARG2]], %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref<!fir.box<none>>, !fir.box<none>, !fir.box<none>, !fir.ref<i8>, 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<!fir.heap<!fir.array<?x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>> {bindc_name = "a", fir.target, uniq_name = "_QMpolymorphic_testFpointer_assign_lower_boundsEa"}
+! CHECK: %[[P:.*]] = fir.alloca !fir.class<!fir.ptr<!fir.array<?x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>> {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.heap<!fir.array<?x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>>, !fir.shift<1>) -> !fir.class<!fir.array<?x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>
+! 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<!fir.array<1xi64>>
+! 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.array<1xi64>>, !fir.shape<1>) -> !fir.box<!fir.array<1xi64>>
+! CHECK: %[[P_BOX_NONE:.*]] = fir.convert %[[P]] : (!fir.ref<!fir.class<!fir.ptr<!fir.array<?x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>>>) -> !fir.ref<!fir.box<none>>
+! CHECK: %[[A_BOX_NONE:.*]] = fir.convert %[[REBOX_A]] : (!fir.class<!fir.array<?x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>) -> !fir.box<none>
+! CHECK: %[[LBOUNDS_BOX_NONE:.*]] = fir.convert %[[LBOUND_ARRAY_BOXED]] : (!fir.box<!fir.array<1xi64>>) -> !fir.box<none>
+! CHECK: %{{.*}} = fir.call @_FortranAPointerAssociateLowerBounds(%[[P_BOX_NONE]], %[[A_BOX_NONE]], %[[LBOUNDS_BOX_NONE]]) {{.*}} : (!fir.ref<!fir.box<none>>, !fir.box<none>, !fir.box<none>) -> none
+
subroutine test_elemental_assign()
type(p1) :: pa(3)
pa = [ 1, 2, 3 ]