diff --git a/flang/include/flang/Runtime/allocatable.h b/flang/include/flang/Runtime/allocatable.h index f0eb8854a3096..2c18ed542bbf9 100644 --- a/flang/include/flang/Runtime/allocatable.h +++ b/flang/include/flang/Runtime/allocatable.h @@ -44,7 +44,7 @@ int RTNAME(AllocatableCheckAllocated)(Descriptor &, 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); diff --git a/flang/lib/Lower/Allocatable.cpp b/flang/lib/Lower/Allocatable.cpp index 5fb8c8d896685..73c50271be604 100644 --- a/flang/lib/Lower/Allocatable.cpp +++ b/flang/lib/Lower/Allocatable.cpp @@ -206,6 +206,24 @@ static mlir::Value genRuntimeAllocateSource(fir::FirOpBuilder &builder, return builder.create(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(loc, + builder) + : fir::runtime::getRuntimeFunc( + loc, builder); + llvm::SmallVector args{box.getAddr(), fir::getBase(mold)}; + llvm::SmallVector operands; + for (auto [fst, snd] : llvm::zip(args, callee.getFunctionType().getInputs())) + operands.emplace_back(builder.createConvert(loc, snd, fst)); + builder.create(loc, callee, operands); +} + /// Generate a runtime call to deallocate memory. static mlir::Value genRuntimeDeallocate(fir::FirOpBuilder &builder, mlir::Location loc, @@ -282,7 +300,7 @@ class AllocateStmtHelper { 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>(stmt.t)) @@ -554,8 +572,14 @@ class AllocateStmtHelper { 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 @@ -651,6 +675,7 @@ class AllocateStmtHelper { 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; }; diff --git a/flang/runtime/allocatable.cpp b/flang/runtime/allocatable.cpp index 58c245cdd1ac5..32eaa9c7e4376 100644 --- a/flang/runtime/allocatable.cpp +++ b/flang/runtime/allocatable.cpp @@ -61,6 +61,10 @@ void RTNAME(AllocatableSetDerivedLength)( 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; diff --git a/flang/test/Lower/allocatable-polymorphic.f90 b/flang/test/Lower/allocatable-polymorphic.f90 index 838f502863b80..bfaf3e88d71aa 100644 --- a/flang/test/Lower/allocatable-polymorphic.f90 +++ b/flang/test/Lower/allocatable-polymorphic.f90 @@ -411,7 +411,6 @@ subroutine test_type_with_polymorphic_pointer_component() 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>>}>> {uniq_name = "_QMpolyFtest_type_with_polymorphic_pointer_componentEa.addr"} @@ -430,6 +429,37 @@ subroutine test_type_with_polymorphic_pointer_component() ! CHECK: %[[ELEMENT_DESC_CAST:.*]] = fir.convert %[[ELEMENT_DESC]] : (!fir.ref>>>) -> !fir.ref> ! CHECK: %{{.*}} = fir.call @_FortranAPointerAllocate(%[[ELEMENT_DESC_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (!fir.ref>, i1, !fir.box, !fir.ref, 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>>> {bindc_name = "p", uniq_name = "_QMpolyFtest_allocate_with_moldEp"} +! CHECK: %[[UP:.*]] = fir.alloca !fir.class>> {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.shape<1>) -> !fir.box>> +! CHECK: %[[P_BOX_NONE:.*]] = fir.convert %[[P]] : (!fir.ref>>>>) -> !fir.ref> +! CHECK: %[[X_BOX_NONE:.*]] = fir.convert %[[EMBOX_X]] : (!fir.box>>) -> !fir.box +! CHECK: %{{.*}} = fir.call @_FortranAPointerApplyMold(%[[P_BOX_NONE]], %[[X_BOX_NONE]]) {{.*}} : (!fir.ref>, !fir.box) -> none +! CHECK: %[[P_BOX_NONE:.*]] = fir.convert %[[P]] : (!fir.ref>>>>) -> !fir.ref> +! CHECK: %{{.*}} = fir.call @_FortranAPointerAllocate(%[[P_BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[EMBOX_I:.*]] = fir.embox %[[I]](%{{.*}}) : (!fir.ref>, !fir.shape<1>) -> !fir.box> +! CHECK: %[[UP_BOX_NONE:.*]] = fir.convert %[[UP]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[I_BOX_NONE:.*]] = fir.convert %[[EMBOX_I]] : (!fir.box>) -> !fir.box +! CHECK: %{{.*}} = fir.call @_FortranAPointerApplyMold(%[[UP_BOX_NONE]], %[[I_BOX_NONE]]) {{.*}} : (!fir.ref>, !fir.box) -> none +! CHECK: %[[UP_BOX_NONE:.*]] = fir.convert %[[UP]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %{{.*}} = fir.call @_FortranAPointerAllocate(%[[UP_BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 + +end module + + program test_alloc use poly diff --git a/flang/test/Lower/allocatable-runtime.f90 b/flang/test/Lower/allocatable-runtime.f90 index 73f939ef6a1d3..b77160f7effab 100644 --- a/flang/test/Lower/allocatable-runtime.f90 +++ b/flang/test/Lower/allocatable-runtime.f90 @@ -163,3 +163,20 @@ subroutine char_explicit_dyn(n, l1, l2) ! 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>> {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.shape<1>) -> !fir.box> +! CHECK: %[[A_BOX_NONE:.*]] = fir.convert %[[A]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[M_BOX_NONE:.*]] = fir.convert %[[EMBOX_M]] : (!fir.box>) -> !fir.box +! CHECK: %{{.*}} = fir.call @_FortranAAllocatableApplyMold(%[[A_BOX_NONE]], %[[M_BOX_NONE]]) {{.*}} : (!fir.ref>, !fir.box) -> none +! CHECK: %[[A_BOX_NONE:.*]] = fir.convert %[[A]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %{{.*}} = fir.call @_FortranAAllocatableAllocate(%[[A_BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32