diff --git a/flang/include/flang/Runtime/allocatable.h b/flang/include/flang/Runtime/allocatable.h --- a/flang/include/flang/Runtime/allocatable.h +++ b/flang/include/flang/Runtime/allocatable.h @@ -46,7 +46,8 @@ // For MOLD= allocation; sets bounds, cobounds, and length type // parameters from another descriptor. The destination descriptor must // be initialized and deallocated. -void RTNAME(AllocatableApplyMold)(Descriptor &, const Descriptor &mold); +void RTNAME(AllocatableApplyMold)( + Descriptor &, const Descriptor &mold, int rank = 0); // Explicitly sets the bounds and length type parameters of an initialized // deallocated allocatable. diff --git a/flang/include/flang/Runtime/pointer.h b/flang/include/flang/Runtime/pointer.h --- a/flang/include/flang/Runtime/pointer.h +++ b/flang/include/flang/Runtime/pointer.h @@ -42,7 +42,8 @@ // For MOLD= allocation: acquires information from another descriptor // to initialize a null data pointer. -void RTNAME(PointerApplyMold)(Descriptor &, const Descriptor &mold); +void RTNAME(PointerApplyMold)( + Descriptor &, const Descriptor &mold, int rank = 0); // Data pointer association for "p=>TARGET" diff --git a/flang/lib/Lower/Allocatable.cpp b/flang/lib/Lower/Allocatable.cpp --- a/flang/lib/Lower/Allocatable.cpp +++ b/flang/lib/Lower/Allocatable.cpp @@ -211,14 +211,17 @@ static void genRuntimeAllocateApplyMold(fir::FirOpBuilder &builder, mlir::Location loc, const fir::MutableBoxValue &box, - fir::ExtendedValue mold) { + fir::ExtendedValue mold, int rank) { 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 args{ + box.getAddr(), fir::getBase(mold), + builder.createIntegerConstant( + loc, callee.getFunctionType().getInputs()[2], rank)}; llvm::SmallVector operands; for (auto [fst, snd] : llvm::zip(args, callee.getFunctionType().getInputs())) operands.emplace_back(builder.createConvert(loc, snd, fst)); @@ -565,7 +568,8 @@ !box.hasNonDeferredLenParams()) lenParams.push_back(fir::factory::readCharLen(builder, loc, sourceExv)); if (alloc.type.IsPolymorphic()) - genRuntimeAllocateApplyMold(builder, loc, box, sourceExv); + genRuntimeAllocateApplyMold(builder, loc, box, sourceExv, + alloc.getSymbol().Rank()); genSetDeferredLengthParameters(alloc, box); genAllocateObjectBounds(alloc, box); mlir::Value stat = @@ -576,7 +580,8 @@ void genMoldAllocation(const Allocation &alloc, const fir::MutableBoxValue &box) { - genRuntimeAllocateApplyMold(builder, loc, box, moldExv); + genRuntimeAllocateApplyMold(builder, loc, box, moldExv, + alloc.getSymbol().Rank()); errorManager.genStatCheck(builder, loc); mlir::Value stat = genRuntimeAllocate(builder, loc, box, errorManager); fir::factory::syncMutableBoxFromIRBox(builder, loc, box); diff --git a/flang/runtime/allocatable.cpp b/flang/runtime/allocatable.cpp --- a/flang/runtime/allocatable.cpp +++ b/flang/runtime/allocatable.cpp @@ -85,7 +85,7 @@ } void RTNAME(AllocatableApplyMold)( - Descriptor &descriptor, const Descriptor &mold) { + Descriptor &descriptor, const Descriptor &mold, int rank) { if (descriptor.IsAllocated()) { // 9.7.1.3 Return so the error can be emitted by AllocatableAllocate. return; @@ -93,6 +93,7 @@ descriptor = mold; descriptor.set_base_addr(nullptr); descriptor.raw().attribute = CFI_attribute_allocatable; + descriptor.raw().rank = rank; } int RTNAME(AllocatableAllocate)(Descriptor &descriptor, bool hasStat, diff --git a/flang/runtime/pointer.cpp b/flang/runtime/pointer.cpp --- a/flang/runtime/pointer.cpp +++ b/flang/runtime/pointer.cpp @@ -54,10 +54,12 @@ addendum->SetLenParameterValue(which, x); } -void RTNAME(PointerApplyMold)(Descriptor &pointer, const Descriptor &mold) { +void RTNAME(PointerApplyMold)( + Descriptor &pointer, const Descriptor &mold, int rank) { pointer = mold; pointer.set_base_addr(nullptr); pointer.raw().attribute = CFI_attribute_pointer; + pointer.raw().rank = rank; } void RTNAME(PointerAssociateScalar)(Descriptor &pointer, void *target) { diff --git a/flang/test/Lower/allocatable-polymorphic.f90 b/flang/test/Lower/allocatable-polymorphic.f90 --- a/flang/test/Lower/allocatable-polymorphic.f90 +++ b/flang/test/Lower/allocatable-polymorphic.f90 @@ -445,15 +445,17 @@ ! 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: %[[RANK:.*]] = arith.constant 1 : i32 ! 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: %{{.*}} = fir.call @_FortranAPointerApplyMold(%[[P_BOX_NONE]], %[[X_BOX_NONE]], %[[RANK]]) {{.*}} : (!fir.ref>, !fir.box, i32) -> 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: %[[RANK:.*]] = arith.constant 1 : i32 ! 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: %{{.*}} = fir.call @_FortranAPointerApplyMold(%[[UP_BOX_NONE]], %[[I_BOX_NONE]], %[[RANK]]) {{.*}} : (!fir.ref>, !fir.box, i32) -> 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 @@ -473,17 +475,19 @@ ! CHECK: %[[UP:.*]] = fir.alloca !fir.class>> {bindc_name = "up", uniq_name = "_QMpolyFtest_allocate_with_sourceEup"} ! CHECK: %[[X:.*]] = fir.alloca !fir.array<10x!fir.type<_QMpolyTp2{a:i32,b:i32,c:i32}>> {bindc_name = "x", uniq_name = "_QMpolyFtest_allocate_with_sourceEx"} ! CHECK: %[[EMBOX_X:.*]] = fir.embox %[[X]](%{{.*}}) : (!fir.ref>>, !fir.shape<1>) -> !fir.box>> +! CHECK: %[[RANK:.*]] = arith.constant 1 : i32 ! 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: %{{.*}} = fir.call @_FortranAPointerApplyMold(%[[P_BOX_NONE]], %[[X_BOX_NONE]], %[[RANK]]) {{.*}} : (!fir.ref>, !fir.box, i32) -> none ! CHECK: %{{.*}} = fir.call @_FortranAPointerSetBounds ! CHECK: %[[BOX_NONE_P:.*]] = fir.convert %[[P]] : (!fir.ref>>>>) -> !fir.ref> ! CHECK: %[[BOX_NONE_X:.*]] = fir.convert %[[EMBOX_X]] : (!fir.box>>) -> !fir.box ! CHECK: %{{.*}} = fir.call @_FortranAPointerAllocateSource(%[[BOX_NONE_P]], %[[BOX_NONE_X]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref>, !fir.box, i1, !fir.box, !fir.ref, i32) -> i32 ! CHECK: %[[EMBOX_I:.*]] = fir.embox %[[I]](%{{.*}}) : (!fir.ref>, !fir.shape<1>) -> !fir.box> +! CHECK: %[[RANK:.*]] = arith.constant 1 : i32 ! 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: %{{.*}} = fir.call @_FortranAPointerApplyMold(%[[UP_BOX_NONE]], %[[I_BOX_NONE]], %[[RANK]]) {{.*}} : (!fir.ref>, !fir.box, i32) -> none ! CHECK: %{{.*}} = fir.call @_FortranAPointerSetBounds ! CHECK: %[[UP_BOX_NONE:.*]] = fir.convert %[[UP]] : (!fir.ref>>>) -> !fir.ref> ! CHECK: %[[I_BOX_NONE:.*]] = fir.convert %[[EMBOX_I]] : (!fir.box>) -> !fir.box @@ -498,13 +502,40 @@ ! CHECK-LABEL: func.func @_QMpolyPtest_allocatable_up_from_up_mold( ! CHECK-SAME: %[[A:.*]]: !fir.ref>> {fir.bindc_name = "a"}, %[[B:.*]]: !fir.ref>> {fir.bindc_name = "b"}) { ! CHECK: %[[LOAD_B:.*]] = fir.load %[[B]] : !fir.ref>> +! CHECK: %[[RANK:.*]] = arith.constant 0 : i32 ! CHECK: %[[A_BOX_NONE:.*]] = fir.convert %[[A]] : (!fir.ref>>) -> !fir.ref> ! CHECK: %[[B_BOX_NONE:.*]] = fir.convert %[[LOAD_B]] : (!fir.class>) -> !fir.box -! CHECK: %{{.*}} = fir.call @_FortranAAllocatableApplyMold(%[[A_BOX_NONE]], %[[B_BOX_NONE]]) {{.*}} : (!fir.ref>, !fir.box) -> none +! CHECK: %{{.*}} = fir.call @_FortranAAllocatableApplyMold(%[[A_BOX_NONE]], %[[B_BOX_NONE]], %[[RANK]]) {{.*}} : (!fir.ref>, !fir.box, i32) -> none ! CHECK: %[[A_BOX_NONE:.*]] = fir.convert %[[A]] : (!fir.ref>>) -> !fir.ref> ! CHECK: %[[B_BOX_NONE:.*]] = fir.convert %[[LOAD_B]] : (!fir.class>) -> !fir.box ! CHECK: %{{.*}} = fir.call @_FortranAAllocatableAllocateSource(%[[A_BOX_NONE]], %[[B_BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref>, !fir.box, i1, !fir.box, !fir.ref, i32) -> i32 + subroutine test_allocatable_up_from_mold_rank(a) + class(*), allocatable :: a(:) + allocate(a(20), source = 10) + end subroutine + +! CHECK-LABEL: func.func @_QMpolyPtest_allocatable_up_from_mold_rank( +! CHECK-SAME: %[[A:.*]]: !fir.ref>>> {fir.bindc_name = "a"}) { +! CHECK: %[[VALUE_10:.*]] = fir.alloca i32 {adapt.valuebyref} +! CHECK: %[[C10:.*]] = arith.constant 10 : i32 +! CHECK: fir.store %[[C10]] to %[[VALUE_10]] : !fir.ref +! CHECK: %[[EMBOX_10:.*]] = fir.embox %[[VALUE_10]] : (!fir.ref) -> !fir.box +! CHECK: %[[RANK:.*]] = arith.constant 1 : i32 +! CHECK: %[[A_BOX_NONE:.*]] = fir.convert %[[A]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[BOX_NONE_10:.*]] = fir.convert %[[EMBOX_10]] : (!fir.box) -> !fir.box +! CHECK: %{{.*}} = fir.call @_FortranAAllocatableApplyMold(%[[A_BOX_NONE]], %[[BOX_NONE_10]], %[[RANK]]) {{.*}} : (!fir.ref>, !fir.box, i32) -> none +! CHECK: %[[C1:.*]] = arith.constant 1 : index +! CHECK: %[[C2:.*]] = arith.constant 20 : i32 +! CHECK: %[[C0:.*]] = arith.constant 0 : i32 +! CHECK: %[[A_BOX_NONE:.*]] = fir.convert %[[A]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[C1_I64:.*]] = fir.convert %[[C1]] : (index) -> i64 +! CHECK: %[[C20_I64:.*]] = fir.convert %[[C20]] : (i32) -> i64 +! CHECK: %{{.*}} = fir.call @_FortranAAllocatableSetBounds(%[[A_BOX_NONE]], %[[C0]], %[[C1_I64]], %[[C20_I64]]) {{.*}} : (!fir.ref>, i32, i64, i64) -> none +! CHECK: %[[A_BOX_NONE:.*]] = fir.convert %[[A]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[BOX_NONE_10:.*]] = fir.convert %[[EMBOX_10]] : (!fir.box) -> !fir.box +! CHECK: %{{.*}} = fir.call @_FortranAAllocatableAllocateSource(%[[A_BOX_NONE]], %[[BOX_NONE_10]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref>, !fir.box, i1, !fir.box, !fir.ref, i32) -> i32 + end module diff --git a/flang/test/Lower/allocatable-runtime.f90 b/flang/test/Lower/allocatable-runtime.f90 --- a/flang/test/Lower/allocatable-runtime.f90 +++ b/flang/test/Lower/allocatable-runtime.f90 @@ -175,8 +175,9 @@ ! 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: %[[RANK:.*]] = arith.constant 1 : i32 ! 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: %{{.*}} = fir.call @_FortranAAllocatableApplyMold(%[[A_BOX_NONE]], %[[M_BOX_NONE]], %[[RANK]]) {{.*}} : (!fir.ref>, !fir.box, i32) -> 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 diff --git a/flang/test/Lower/polymorphic-temp.f90 b/flang/test/Lower/polymorphic-temp.f90 --- a/flang/test/Lower/polymorphic-temp.f90 +++ b/flang/test/Lower/polymorphic-temp.f90 @@ -75,9 +75,10 @@ ! CHECK: %[[I_BOX_NONE:.*]] = fir.convert %[[I]] : (!fir.class>) -> !fir.box ! CHECK: %{{.*}} = fir.call @_FortranAReshape(%[[RES_BOX_NONE]], %[[I_BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref>, !fir.box, !fir.box, !fir.box, !fir.box, !fir.ref, i32) -> none ! CHECK: %[[LOAD_RES:.*]] = fir.load %[[TMP_RES]] : !fir.ref>>> +! CHECK: %[[RANK:.*]] = arith.constant 2 : i32 ! CHECK: %[[A_BOX_NONE:.*]] = fir.convert %[[A]] : (!fir.ref>>>) -> !fir.ref> ! CHECK: %[[RES_BOX_NONE:.*]] = fir.convert %[[LOAD_RES]] : (!fir.class>>) -> !fir.box -! CHECK: %{{.*}} = fir.call @_FortranAAllocatableApplyMold(%[[A_BOX_NONE]], %[[RES_BOX_NONE]]) {{.*}} : (!fir.ref>, !fir.box) -> none +! CHECK: %{{.*}} = fir.call @_FortranAAllocatableApplyMold(%[[A_BOX_NONE]], %[[RES_BOX_NONE]], %[[RANK]]) {{.*}} : (!fir.ref>, !fir.box, i32) -> none subroutine check_pack(r) class(p1) :: r(:)