int sourceLine = 0);
// For MOLD= allocation; sets bounds, cobounds, and length type
-// parameters from another descriptor. The destination descriptor must
+// parameters from another descriptor. The destination descriptor must
// be initialized and deallocated.
void RTNAME(AllocatableApplyMold)(Descriptor &, const Descriptor &mold);
return builder.create<fir::CallOp>(loc, callee, operands).getResult(0);
}
+/// Generate runtime call to apply mold to the descriptor.
+static void genRuntimeAllocateApplyMold(fir::FirOpBuilder &builder,
+ mlir::Location loc,
+ const fir::MutableBoxValue &box,
+ fir::ExtendedValue mold) {
+ mlir::func::FuncOp callee =
+ box.isPointer()
+ ? fir::runtime::getRuntimeFunc<mkRTKey(PointerApplyMold)>(loc,
+ builder)
+ : fir::runtime::getRuntimeFunc<mkRTKey(AllocatableApplyMold)>(
+ loc, builder);
+ llvm::SmallVector<mlir::Value> args{box.getAddr(), fir::getBase(mold)};
+ llvm::SmallVector<mlir::Value> operands;
+ for (auto [fst, snd] : llvm::zip(args, callee.getFunctionType().getInputs()))
+ operands.emplace_back(builder.createConvert(loc, snd, fst));
+ builder.create<fir::CallOp>(loc, callee, operands);
+}
+
/// Generate a runtime call to deallocate memory.
static mlir::Value genRuntimeDeallocate(fir::FirOpBuilder &builder,
mlir::Location loc,
if (sourceExpr)
sourceExv = converter.genExprBox(loc, *sourceExpr, stmtCtx);
if (moldExpr)
- TODO(loc, "lower MOLD expr in allocate");
+ moldExv = converter.genExprBox(loc, *moldExpr, stmtCtx);
mlir::OpBuilder::InsertPoint insertPt = builder.saveInsertionPoint();
for (const auto &allocation :
std::get<std::list<Fortran::parser::Allocation>>(stmt.t))
fir::factory::syncMutableBoxFromIRBox(builder, loc, box);
errorManager.assignStat(builder, loc, stat);
}
- void genMoldAllocation(const Allocation &, const fir::MutableBoxValue &) {
- TODO(loc, "MOLD allocation");
+
+ void genMoldAllocation(const Allocation &alloc,
+ const fir::MutableBoxValue &box) {
+ genRuntimeAllocateApplyMold(builder, loc, box, moldExv);
+ errorManager.genStatCheck(builder, loc);
+ mlir::Value stat = genRuntimeAllocate(builder, loc, box, errorManager);
+ fir::factory::syncMutableBoxFromIRBox(builder, loc, box);
+ errorManager.assignStat(builder, loc, stat);
}
/// Generate call to the AllocatableInitDerived to set up the type descriptor
ErrorManager errorManager;
// 9.7.1.2(7) The source-expr is evaluated exactly once for each AllocateStmt.
fir::ExtendedValue sourceExv;
+ fir::ExtendedValue moldExv;
mlir::Location loc;
};
void RTNAME(AllocatableApplyMold)(
Descriptor &descriptor, const Descriptor &mold) {
+ if (descriptor.IsAllocated()) {
+ // 9.7.1.3 Return so the error can be emitted by AllocatableAllocate.
+ return;
+ }
descriptor = mold;
descriptor.set_base_addr(nullptr);
descriptor.raw().attribute = CFI_attribute_allocatable;
allocate(a)
allocate(a%element)
end subroutine
-end module
! CHECK-LABEL: func.func @_QMpolyPtest_type_with_polymorphic_pointer_component()
! CHECK: %[[TYPE_PTR:.*]] = fir.alloca !fir.ptr<!fir.type<_QMpolyTwith_alloc{element:!fir.class<!fir.ptr<!fir.type<_QMpolyTp1{a:i32,b:i32}>>>}>> {uniq_name = "_QMpolyFtest_type_with_polymorphic_pointer_componentEa.addr"}
! CHECK: %[[ELEMENT_DESC_CAST:.*]] = fir.convert %[[ELEMENT_DESC]] : (!fir.ref<!fir.class<!fir.ptr<!fir.type<_QMpolyTp1{a:i32,b:i32}>>>>) -> !fir.ref<!fir.box<none>>
! CHECK: %{{.*}} = fir.call @_FortranAPointerAllocate(%[[ELEMENT_DESC_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref<!fir.box<none>>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
+ subroutine test_allocate_with_mold()
+ type(p2) :: x(10)
+ class(p1), pointer :: p(:)
+ integer(4) :: i(20)
+ class(*), pointer :: up(:)
+
+ allocate(p, mold=x)
+ allocate(up, mold=i)
+ end subroutine
+
+! CHECK-LABEL: func.func @_QMpolyPtest_allocate_with_mold() {
+! CHECK: %[[I:.*]] = fir.alloca !fir.array<20xi32> {bindc_name = "i", uniq_name = "_QMpolyFtest_allocate_with_moldEi"}
+! CHECK: %[[P:.*]] = fir.alloca !fir.class<!fir.ptr<!fir.array<?x!fir.type<_QMpolyTp1{a:i32,b:i32}>>>> {bindc_name = "p", uniq_name = "_QMpolyFtest_allocate_with_moldEp"}
+! CHECK: %[[UP:.*]] = fir.alloca !fir.class<!fir.ptr<!fir.array<?xnone>>> {bindc_name = "up", uniq_name = "_QMpolyFtest_allocate_with_moldEup"}
+! CHECK: %[[X:.*]] = fir.alloca !fir.array<10x!fir.type<_QMpolyTp2{a:i32,b:i32,c:i32}>> {bindc_name = "x", uniq_name = "_QMpolyFtest_allocate_with_moldEx"}
+! CHECK: %[[EMBOX_X:.*]] = fir.embox %[[X]](%{{.*}}) : (!fir.ref<!fir.array<10x!fir.type<_QMpolyTp2{a:i32,b:i32,c:i32}>>>, !fir.shape<1>) -> !fir.box<!fir.array<10x!fir.type<_QMpolyTp2{a:i32,b:i32,c:i32}>>>
+! CHECK: %[[P_BOX_NONE:.*]] = fir.convert %[[P]] : (!fir.ref<!fir.class<!fir.ptr<!fir.array<?x!fir.type<_QMpolyTp1{a:i32,b:i32}>>>>>) -> !fir.ref<!fir.box<none>>
+! CHECK: %[[X_BOX_NONE:.*]] = fir.convert %[[EMBOX_X]] : (!fir.box<!fir.array<10x!fir.type<_QMpolyTp2{a:i32,b:i32,c:i32}>>>) -> !fir.box<none>
+! CHECK: %{{.*}} = fir.call @_FortranAPointerApplyMold(%[[P_BOX_NONE]], %[[X_BOX_NONE]]) {{.*}} : (!fir.ref<!fir.box<none>>, !fir.box<none>) -> none
+! CHECK: %[[P_BOX_NONE:.*]] = fir.convert %[[P]] : (!fir.ref<!fir.class<!fir.ptr<!fir.array<?x!fir.type<_QMpolyTp1{a:i32,b:i32}>>>>>) -> !fir.ref<!fir.box<none>>
+! CHECK: %{{.*}} = fir.call @_FortranAPointerAllocate(%[[P_BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref<!fir.box<none>>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
+! CHECK: %[[EMBOX_I:.*]] = fir.embox %[[I]](%{{.*}}) : (!fir.ref<!fir.array<20xi32>>, !fir.shape<1>) -> !fir.box<!fir.array<20xi32>>
+! CHECK: %[[UP_BOX_NONE:.*]] = fir.convert %[[UP]] : (!fir.ref<!fir.class<!fir.ptr<!fir.array<?xnone>>>>) -> !fir.ref<!fir.box<none>>
+! CHECK: %[[I_BOX_NONE:.*]] = fir.convert %[[EMBOX_I]] : (!fir.box<!fir.array<20xi32>>) -> !fir.box<none>
+! CHECK: %{{.*}} = fir.call @_FortranAPointerApplyMold(%[[UP_BOX_NONE]], %[[I_BOX_NONE]]) {{.*}} : (!fir.ref<!fir.box<none>>, !fir.box<none>) -> none
+! CHECK: %[[UP_BOX_NONE:.*]] = fir.convert %[[UP]] : (!fir.ref<!fir.class<!fir.ptr<!fir.array<?xnone>>>>) -> !fir.ref<!fir.box<none>>
+! CHECK: %{{.*}} = fir.call @_FortranAPointerAllocate(%[[UP_BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref<!fir.box<none>>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
+
+end module
+
+
program test_alloc
use poly
! CHECK: AllocatableDeallocate
! CHECK: AllocatableDeallocate
end subroutine
+
+subroutine mold_allocation()
+ integer :: m(10)
+ integer, allocatable :: a(:)
+
+ allocate(a, mold=m)
+end subroutine
+
+! CHECK-LABEL: func.func @_QPmold_allocation() {
+! CHECK: %[[A:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?xi32>>> {bindc_name = "a", uniq_name = "_QFmold_allocationEa"}
+! CHECK: %[[M:.*]] = fir.alloca !fir.array<10xi32> {bindc_name = "m", uniq_name = "_QFmold_allocationEm"}
+! CHECK: %[[EMBOX_M:.*]] = fir.embox %[[M]](%{{.*}}) : (!fir.ref<!fir.array<10xi32>>, !fir.shape<1>) -> !fir.box<!fir.array<10xi32>>
+! CHECK: %[[A_BOX_NONE:.*]] = fir.convert %[[A]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>) -> !fir.ref<!fir.box<none>>
+! CHECK: %[[M_BOX_NONE:.*]] = fir.convert %[[EMBOX_M]] : (!fir.box<!fir.array<10xi32>>) -> !fir.box<none>
+! CHECK: %{{.*}} = fir.call @_FortranAAllocatableApplyMold(%[[A_BOX_NONE]], %[[M_BOX_NONE]]) {{.*}} : (!fir.ref<!fir.box<none>>, !fir.box<none>) -> none
+! CHECK: %[[A_BOX_NONE:.*]] = fir.convert %[[A]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>) -> !fir.ref<!fir.box<none>>
+! CHECK: %{{.*}} = fir.call @_FortranAAllocatableAllocate(%[[A_BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref<!fir.box<none>>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32