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 @@ -621,6 +621,19 @@ !sym.attrs().test(Fortran::semantics::Attr::CONTIGUOUS); } +/// Is this symbol a polymorphic pointer? +static inline bool isPolymorphicPointer(const Fortran::semantics::Symbol &sym) { + return Fortran::semantics::IsPointer(sym) && + Fortran::semantics::IsPolymorphic(sym); +} + +/// Is this symbol a polymorphic allocatable? +static inline bool +isPolymorphicAllocatable(const Fortran::semantics::Symbol &sym) { + return Fortran::semantics::IsAllocatable(sym) && + Fortran::semantics::IsPolymorphic(sym); +} + /// Is this a local procedure symbol in a procedure that contains internal /// procedures ? static bool mayBeCapturedInInternalProc(const Fortran::semantics::Symbol &sym) { @@ -665,7 +678,8 @@ Fortran::semantics::IsFunctionResult(sym) || sym.attrs().test(Fortran::semantics::Attr::VOLATILE) || isNonContiguousArrayPointer(sym) || useAllocateRuntime || - useDescForMutableBox || mayBeCapturedInInternalProc(sym)) + useDescForMutableBox || mayBeCapturedInInternalProc(sym) || + isPolymorphicPointer(sym) || isPolymorphicAllocatable(sym)) return {}; fir::MutableProperties mutableProperties; std::string name = converter.mangleName(sym); @@ -754,6 +768,7 @@ fir::ExtendedValue rhs = isArraySectionWithoutVectorSubscript(source) ? converter.genExprBox(loc, source, stmtCtx) : converter.genExprAddr(loc, source, stmtCtx); + fir::factory::associateMutableBox(builder, loc, box, rhs, lbounds); } 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 @@ -2442,9 +2442,16 @@ std::optional rhsType = assign.rhs.GetType(); // Polymorphic lhs/rhs may need more care. See F2018 10.2.2.3. - if ((lhsType && lhsType->IsPolymorphic()) || + // If the pointer object is not polymorphic (7.3.2.3) and the + // pointer target is polymorphic with dynamic type that differs + // from its declared type, the assignment target is the ancestor + // component of the pointer target that has the type of the + // pointer object. Otherwise, the assignment target is the pointer + // target. + if ((lhsType && !lhsType->IsPolymorphic()) && (rhsType && rhsType->IsPolymorphic())) - TODO(loc, "pointer assignment involving polymorphic entity"); + TODO(loc, "non-polymorphic pointer assignment with polymorphic " + "entity on rhs"); llvm::SmallVector lbounds; for (const Fortran::evaluate::ExtentExpr &lbExpr : lbExprs) diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp --- a/flang/lib/Lower/ConvertExpr.cpp +++ b/flang/lib/Lower/ConvertExpr.cpp @@ -3747,7 +3747,7 @@ [&](const auto &e) { auto f = genarr(e); ExtValue exv = f(IterationSpace{}); - if (fir::getBase(exv).getType().template isa()) + if (fir::getBase(exv).getType().template isa()) return exv; fir::emitFatalError(getLoc(), "array must be emboxed"); }, @@ -5912,7 +5912,9 @@ // This case just requires that an embox operation be created to box the // value. The value of the box is forwarded in the continuation. mlir::Type reduceTy = reduceRank(arrTy, slice); - auto boxTy = fir::BoxType::get(reduceTy); + mlir::Type boxTy = fir::BoxType::get(reduceTy); + if (memref.getType().isa()) + boxTy = fir::ClassType::get(reduceTy); if (components.substring) { // Adjust char length to substring size. fir::CharacterType charTy = @@ -5925,7 +5927,7 @@ seqTy.getDimension())); } mlir::Value embox = - memref.getType().isa() + memref.getType().isa() ? builder.create(loc, boxTy, memref, shape, slice) .getResult() : builder diff --git a/flang/lib/Optimizer/Builder/MutableBox.cpp b/flang/lib/Optimizer/Builder/MutableBox.cpp --- a/flang/lib/Optimizer/Builder/MutableBox.cpp +++ b/flang/lib/Optimizer/Builder/MutableBox.cpp @@ -22,12 +22,11 @@ /// Create a fir.box describing the new address, bounds, and length parameters /// for a MutableBox \p box. -static mlir::Value createNewFirBox(fir::FirOpBuilder &builder, - mlir::Location loc, - const fir::MutableBoxValue &box, - mlir::Value addr, mlir::ValueRange lbounds, - mlir::ValueRange extents, - mlir::ValueRange lengths) { +static mlir::Value +createNewFirBox(fir::FirOpBuilder &builder, mlir::Location loc, + const fir::MutableBoxValue &box, mlir::Value addr, + mlir::ValueRange lbounds, mlir::ValueRange extents, + mlir::ValueRange lengths, mlir::Value tdesc = {}) { if (addr.getType().isa()) // The entity is already boxed. return builder.createConvert(loc, box.getBoxTy(), addr); @@ -72,7 +71,7 @@ } mlir::Value emptySlice; return builder.create(loc, box.getBoxTy(), cleanedAddr, shape, - emptySlice, cleanedLengths); + emptySlice, cleanedLengths, tdesc); } //===----------------------------------------------------------------------===// @@ -201,11 +200,12 @@ /// Length parameters must be provided for the length parameters that are /// deferred. void updateMutableBox(mlir::Value addr, mlir::ValueRange lbounds, - mlir::ValueRange extents, mlir::ValueRange lengths) { + mlir::ValueRange extents, mlir::ValueRange lengths, + mlir::Value tdesc = {}) { if (box.isDescribedByVariables()) updateMutableProperties(addr, lbounds, extents, lengths); else - updateIRBox(addr, lbounds, extents, lengths); + updateIRBox(addr, lbounds, extents, lengths, tdesc); } /// Update MutableBoxValue with a new fir.box. This requires that the mutable @@ -267,9 +267,10 @@ private: /// Update the IR box (fir.ref>) of the MutableBoxValue. void updateIRBox(mlir::Value addr, mlir::ValueRange lbounds, - mlir::ValueRange extents, mlir::ValueRange lengths) { - mlir::Value irBox = - createNewFirBox(builder, loc, box, addr, lbounds, extents, lengths); + mlir::ValueRange extents, mlir::ValueRange lengths, + mlir::Value tdesc = {}) { + mlir::Value irBox = createNewFirBox(builder, loc, box, addr, lbounds, + extents, lengths, tdesc); builder.create(loc, irBox, box.getAddr()); } @@ -477,8 +478,12 @@ MutablePropertyWriter writer(builder, loc, box); source.match( [&](const fir::PolymorphicValue &p) { + mlir::Value tdesc; + if (auto polyBox = source.getBoxOf()) + tdesc = polyBox->getTdesc(); writer.updateMutableBox(p.getAddr(), /*lbounds=*/llvm::None, - /*extents=*/llvm::None, /*lengths=*/llvm::None); + /*extents=*/llvm::None, /*lengths=*/llvm::None, + tdesc); }, [&](const fir::UnboxedValue &addr) { writer.updateMutableBox(addr, /*lbounds=*/llvm::None, 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 @@ -84,13 +84,10 @@ ! CHECK-LABEL: func.func @_QMpolyPtest_pointer() ! CHECK: %[[C1_DESC:.*]] = fir.alloca !fir.class>> {bindc_name = "c1", uniq_name = "_QMpolyFtest_pointerEc1"} -! CHECK: %[[C1_ADDR:.*]] = fir.alloca !fir.ptr> {uniq_name = "_QMpolyFtest_pointerEc1.addr"} ! CHECK: %[[C2_DESC:.*]] = fir.alloca !fir.class>> {bindc_name = "c2", uniq_name = "_QMpolyFtest_pointerEc2"} -! CHECK: %[[C2_ADDR:.*]] = fir.alloca !fir.ptr> {uniq_name = "_QMpolyFtest_pointerEc2.addr"} ! CHECK: %[[C3_DESC:.*]] = fir.alloca !fir.class>>> {bindc_name = "c3", uniq_name = "_QMpolyFtest_pointerEc3"} ! CHECK: %[[C4_DESC:.*]] = fir.alloca !fir.class>>> {bindc_name = "c4", uniq_name = "_QMpolyFtest_pointerEc4"} ! CHECK: %[[P_DESC:.*]] = fir.alloca !fir.class>> {bindc_name = "p", uniq_name = "_QMpolyFtest_pointerEp"} -! CHECK: %[[P_ADDR:.*]] = fir.alloca !fir.ptr> {uniq_name = "_QMpolyFtest_pointerEp.addr"} ! CHECK: %[[TYPE_DESC_P1:.*]] = fir.address_of(@_QMpolyE.dt.p1) : !fir.ref> ! CHECK: %[[P_DESC_CAST:.*]] = fir.convert %[[P_DESC]] : (!fir.ref>>>) -> !fir.ref> @@ -100,9 +97,10 @@ ! CHECK: %{{.*}} = fir.call @_FortranAPointerNullifyDerived(%[[P_DESC_CAST]], %[[TYPE_DESC_P1_CAST]], %[[RANK]], %[[CORANK]]) : (!fir.ref>, !fir.ref, i32, i32) -> none ! CHECK: %[[P_DESC_CAST:.*]] = fir.convert %[[P_DESC]] : (!fir.ref>>>) -> !fir.ref> ! CHECK: %{{.*}} = fir.call @_FortranAPointerAllocate(%[[P_DESC_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 -! CHECK: %[[P_LOAD:.*]] = fir.load %[[P_DESC]] : !fir.ref>>> -! CHECK: %[[BOX_ADDR:.*]] = fir.box_addr %[[P_LOAD]] : (!fir.class>>) -> !fir.ptr> -! CHECK: fir.store %[[BOX_ADDR]] to %[[P_ADDR]] : !fir.ref>> + +! call p%proc1() +! CHECK: %[[P_CAST:.*]] = fir.convert %[[P_DESC:.*]] : (!fir.ref>>>) -> !fir.class>> +! CHECK: fir.dispatch "proc1"(%[[P_CAST]] : !fir.class>>) ! CHECK: %[[TYPE_DESC_P1:.*]] = fir.address_of(@_QMpolyE.dt.p1) : !fir.ref> ! CHECK: %[[C1_DESC_CAST:.*]] = fir.convert %[[C1_DESC:.*]] : (!fir.ref>>>) -> !fir.ref> @@ -112,9 +110,6 @@ ! CHECK: %{{.*}} = fir.call @_FortranAPointerNullifyDerived(%[[C1_DESC_CAST]], %[[TYPE_DESC_P1_CAST]], %[[RANK]], %[[CORANK]]) : (!fir.ref>, !fir.ref, i32, i32) -> none ! CHECK: %[[C1_DESC_CAST:.*]] = fir.convert %[[C1_DESC]] : (!fir.ref>>>) -> !fir.ref> ! CHECK: %{{.*}} = fir.call @_FortranAPointerAllocate(%[[C1_DESC_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 -! CHECK: %[[C1_LOAD:.*]] = fir.load %[[C1_DESC]] : !fir.ref>>> -! CHECK: %[[BOX_ADDR:.*]] = fir.box_addr %[[C1_LOAD]] : (!fir.class>>) -> !fir.ptr> -! CHECK: fir.store %[[BOX_ADDR]] to %[[C1_ADDR]] : !fir.ref>> ! CHECK: %[[TYPE_DESC_P2:.*]] = fir.address_of(@_QMpolyE.dt.p2) : !fir.ref> ! CHECK: %[[C2_DESC_CAST:.*]] = fir.convert %[[C2_DESC]] : (!fir.ref>>>) -> !fir.ref> @@ -124,9 +119,6 @@ ! CHECK: %{{.*}} = fir.call @_FortranAPointerNullifyDerived(%[[C2_DESC_CAST]], %[[TYPE_DESC_P2_CAST]], %[[RANK]], %[[CORANK]]) : (!fir.ref>, !fir.ref, i32, i32) -> none ! CHECK: %[[C2_DESC_CAST:.*]] = fir.convert %[[C2_DESC]] : (!fir.ref>>>) -> !fir.ref> ! CHECK: %{{.*}} = fir.call @_FortranAPointerAllocate(%[[C2_DESC_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 -! CHECK: %[[C2_LOAD:.*]] = fir.load %[[C2_DESC]] : !fir.ref>>> -! CHECK: %[[BOX_ADDR:.*]] = fir.box_addr %[[C2_LOAD]] : (!fir.class>>) -> !fir.ptr> -! CHECK: fir.store %[[BOX_ADDR]] to %[[C2_ADDR]] : !fir.ref>> ! call c1%proc1() ! CHECK: %[[C1_DESC_CAST:.*]] = fir.convert %[[C1_DESC]] : (!fir.ref>>>) -> !fir.class>> @@ -137,18 +129,14 @@ ! CHECK: fir.dispatch "proc1"(%[[C2_DESC_CAST]] : !fir.class>>) ! call c1%proc2() -! CHECK: %[[C1_LOAD:.*]] = fir.load %[[C1_ADDR]] : !fir.ref>> -! CHECK: %[[C1_DESC_LOAD:.*]] = fir.load %[[C1_DESC]] : !fir.ref>>> -! CHECK: %[[C1_TDESC:.*]] = fir.box_tdesc %[[C1_DESC_LOAD]] : (!fir.class>>) -> !fir.tdesc -! CHECK: %[[C1_BOXED:.*]] = fir.embox %[[C1_LOAD]] tdesc %[[C1_TDESC]] : (!fir.ptr>, !fir.tdesc) -> !fir.class> -! CHECK: fir.dispatch "proc2"(%[[C1_BOXED]] : !fir.class>) (%[[C1_BOXED]] : !fir.class>) {pass_arg_pos = 0 : i32} +! CHECK: %[[C1_LOAD:.*]] = fir.load %[[C1_DESC]] : !fir.ref>>> +! CHECK: %[[C1_REBOX:.*]] = fir.rebox %[[C1_LOAD]] : (!fir.class>>) -> !fir.class> +! CHECK: fir.dispatch "proc2"(%[[C1_REBOX]] : !fir.class>) (%[[C1_REBOX]] : !fir.class>) {pass_arg_pos = 0 : i32} ! call c2%proc2() -! CHECK: %[[C2_LOAD:.*]] = fir.load %[[C2_ADDR]] : !fir.ref>> -! CHECK: %[[C2_DESC_LOAD:.*]] = fir.load %[[C2_DESC]] : !fir.ref>>> -! CHECK: %[[C2_TDESC:.*]] = fir.box_tdesc %[[C2_DESC_LOAD]] : (!fir.class>>) -> !fir.tdesc -! CHECK: %[[C2_BOXED:.*]] = fir.embox %[[C2_LOAD]] tdesc %[[C2_TDESC]] : (!fir.ptr>, !fir.tdesc) -> !fir.class> -! CHECK: fir.dispatch "proc2"(%[[C2_BOXED]] : !fir.class>) (%[[C2_BOXED]] : !fir.class>) {pass_arg_pos = 0 : i32} +! CHECK: %[[C2_LOAD:.*]] = fir.load %[[C2_DESC]] : !fir.ref>>> +! CHECK: %[[C2_REBOX:.*]] = fir.rebox %[[C2_LOAD]] : (!fir.class>>) -> !fir.class> +! CHECK: fir.dispatch "proc2"(%[[C2_REBOX]] : !fir.class>) (%[[C2_REBOX]] : !fir.class>) {pass_arg_pos = 0 : i32} ! CHECK: %[[TYPE_DESC_P1:.*]] = fir.address_of(@_QMpolyE.dt.p1) : !fir.ref> ! CHECK: %[[C3_CAST:.*]] = fir.convert %[[C3_DESC]] : (!fir.ref>>>>) -> !fir.ref> @@ -190,10 +178,10 @@ ! CHECK: %{{.*}} = fir.call @_FortranAPointerDeallocate(%[[P_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 ! CHECK: %[[C1_DESC_CAST:.*]] = fir.convert %[[C1_DESC]] : (!fir.ref>>>) -> !fir.ref> -! CHECK: %147 = fir.call @_FortranAPointerDeallocate(%[[C1_DESC_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %{{.*}} = fir.call @_FortranAPointerDeallocate(%[[C1_DESC_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 ! CHECK: %[[C2_DESC_CAST:.*]] = fir.convert %[[C2_DESC]] : (!fir.ref>>>) -> !fir.ref> -! CHECK: %{{.*}} = fir.call @_FortranAPointerDeallocate(%154, %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %{{.*}} = fir.call @_FortranAPointerDeallocate(%[[C2_DESC_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 ! CHECK: %[[C3_DESC_CAST:.*]] = fir.convert %[[C3_DESC]] : (!fir.ref>>>>) -> !fir.ref> ! CHECK: %{{.*}} = fir.call @_FortranAPointerDeallocate(%[[C3_DESC_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 @@ -247,13 +235,9 @@ ! CHECK-LABEL: func.func @_QMpolyPtest_allocatable() ! CHECK-DAG: %[[C1:.*]] = fir.alloca !fir.class>> {bindc_name = "c1", uniq_name = "_QMpolyFtest_allocatableEc1"} -! CHECK-DAG: %[[C1_ADDR:.*]] = fir.alloca !fir.heap> {uniq_name = "_QMpolyFtest_allocatableEc1.addr"} ! CHECK-DAG: %[[C2:.*]] = fir.alloca !fir.class>> {bindc_name = "c2", uniq_name = "_QMpolyFtest_allocatableEc2"} -! CHECK-DAG: %[[C2_ADDR:.*]] = fir.alloca !fir.heap> {uniq_name = "_QMpolyFtest_allocatableEc2.addr"} ! CHECK-DAG: %[[C3:.*]] = fir.alloca !fir.class>>> {bindc_name = "c3", uniq_name = "_QMpolyFtest_allocatableEc3"} -! CHECK-DAG: %[[C3_ADDR:.*]] = fir.alloca !fir.heap>> {uniq_name = "_QMpolyFtest_allocatableEc3.addr"} ! CHECK-DAG: %[[C4:.*]] = fir.alloca !fir.class>>> {bindc_name = "c4", uniq_name = "_QMpolyFtest_allocatableEc4"} -! CHECK-DAG: %[[C4_ADDR:.*]] = fir.alloca !fir.heap>> {uniq_name = "_QMpolyFtest_allocatableEc4.addr"} ! CHECK-DAG: %[[P:.*]] = fir.alloca !fir.class>> {bindc_name = "p", uniq_name = "_QMpolyFtest_allocatableEp"} ! CHECK: %[[TYPE_DESC_P1:.*]] = fir.address_of(@_QMpolyE.dt.p1) : !fir.ref>>>>) -> !fir.ref> ! CHECK: %{{.*}} = fir.call @_FortranAAllocatableAllocate(%[[C4_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 -! CHECK: %[[C1_ADDR_LOAD:.*]] = fir.load %[[C1_ADDR]] : !fir.ref>> -! CHECK: %[[C1_LOAD:.*]] = fir.load %[[C1]] : !fir.ref>>> -! CHECK: %[[C1_TDESC:.*]] = fir.box_tdesc %[[C1_LOAD]] : (!fir.class>>) -> !fir.tdesc -! CHECK: %[[C1_EMBOX:.*]] = fir.embox %[[C1_ADDR_LOAD]] tdesc %[[C1_TDESC]] : (!fir.heap>, !fir.tdesc) -> !fir.class> -! CHECK: fir.dispatch "proc2"(%[[C1_EMBOX]] : !fir.class>) (%[[C1_EMBOX]] : !fir.class>) {pass_arg_pos = 0 : i32} +! CHECK: %[[C1_CAST:.*]] = fir.convert %[[C1_DESC]] : (!fir.ref>>>) -> !fir.class>> +! CHECK: fir.dispatch "proc1"(%[[C1_CAST]] : !fir.class>>) + +! CHECK: %[[C2_CAST:.*]] = fir.convert %[[C2_DESC]] : (!fir.ref>>>) -> !fir.class>> +! CHECK: fir.dispatch "proc1"(%[[C2_CAST]] : !fir.class>>) + +! CHECK: %[[C1_LOAD:.*]] = fir.load %[[C1_DESC]] : !fir.ref>>> +! CHECK: %[[C1_REBOX:.*]] = fir.rebox %[[C1_LOAD]] : (!fir.class>>) -> !fir.class> +! CHECK: fir.dispatch "proc2"(%[[C1_REBOX]] : !fir.class>) (%[[C1_REBOX]] : !fir.class>) {pass_arg_pos = 0 : i32} -! CHECK: %[[C2_ADDR_LOAD:.*]] = fir.load %[[C2_ADDR]] : !fir.ref>> -! CHECK: %[[C2_LOAD:.*]] = fir.load %[[C2]] : !fir.ref>>> -! CHECK: %[[C2_TDESC:.*]] = fir.box_tdesc %[[C2_LOAD]] : (!fir.class>>) -> !fir.tdesc -! CHECK: %[[C2_EMBOX:.*]] = fir.embox %[[C2_ADDR_LOAD]] tdesc %[[C2_TDESC]] : (!fir.heap>, !fir.tdesc) -> !fir.class> -! CHECK: fir.dispatch "proc2"(%[[C2_EMBOX]] : !fir.class>) (%[[C2_EMBOX]] : !fir.class>) {pass_arg_pos = 0 : i32} +! CHECK: %[[C2_LOAD:.*]] = fir.load %[[C2_DESC]] : !fir.ref>>> +! CHECK: %[[C2_REBOX:.*]] = fir.rebox %[[C2_LOAD]] : (!fir.class>>) -> !fir.class> +! CHECK: fir.dispatch "proc2"(%[[C2_REBOX]] : !fir.class>) (%[[C2_REBOX]] : !fir.class>) {pass_arg_pos = 0 : i32} ! CHECK-LABEL: %{{.*}} = fir.do_loop -! CHECK: %[[C3_ADDR_LOAD:.*]] = fir.load %[[C3_ADDR]] : !fir.ref>>> -! CHECK: %[[C3_LOAD:.*]] = fir.load %[[C3]] : !fir.ref>>>> +! CHECK: %[[C3_LOAD:.*]] = fir.load %[[C3_DESC]] : !fir.ref>>>> +! CHECK: %[[C3_COORD:.*]] = fir.coordinate_of %[[C3_LOAD]], %{{.*}} : (!fir.class>>>, i64) -> !fir.ref> ! CHECK: %[[C3_TDESC:.*]] = fir.box_tdesc %[[C3_LOAD]] : (!fir.class>>>) -> !fir.tdesc -! CHECK: %[[C3_COORD:.*]] = fir.coordinate_of %[[C3_ADDR_LOAD]], %{{.*}} : (!fir.heap>>, i64) -> !fir.ref> ! CHECK: %[[C3_EMBOX:.*]] = fir.embox %[[C3_COORD]] tdesc %[[C3_TDESC]] : (!fir.ref>, !fir.tdesc) -> !fir.class> ! CHECK: fir.dispatch "proc2"(%[[C3_EMBOX]] : !fir.class>) (%[[C3_EMBOX]] : !fir.class>) {pass_arg_pos = 0 : i32} ! CHECK-LABEL: %{{.*}} = fir.do_loop -! CHECK: %[[C4_ADDR_LOAD:.*]] = fir.load %[[C4_ADDR]] : !fir.ref>>> ! CHECK: %[[C4_LOAD:.*]] = fir.load %[[C4]] : !fir.ref>>>> +! CHECK: %[[C4_COORD:.*]] = fir.coordinate_of %[[C4_LOAD]], %{{.*}} : (!fir.class>>>, i64) -> !fir.ref> ! CHECK: %[[C4_TDESC:.*]] = fir.box_tdesc %[[C4_LOAD]] : (!fir.class>>>) -> !fir.tdesc -! CHECK: %[[C4_COORD:.*]] = fir.coordinate_of %[[C4_ADDR_LOAD]], %{{.*}} : (!fir.heap>>, i64) -> !fir.ref> ! CHECK: %[[C4_EMBOX:.*]] = fir.embox %[[C4_COORD]] tdesc %[[C4_TDESC]] : (!fir.ref>, !fir.tdesc) -> !fir.class> ! CHECK: fir.dispatch "proc2"(%[[C4_EMBOX]] : !fir.class>) (%[[C4_EMBOX]] : !fir.class>) {pass_arg_pos = 0 : i32} @@ -435,33 +419,10 @@ ! LLVM-LABEL: define void @_QMpolyPtest_deallocate() ! LLVM: %[[ALLOCA1:.*]] = alloca { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } -! LLVM: %[[ALLOCA2:.*]] = alloca { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } -! LLVM: %[[ALLOCA3:.*]] = alloca { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } -! LLVM: %[[ALLOCA4:.*]] = alloca { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } -! LLVM: %[[DESC:.*]] = alloca { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] }, i64 1 -! LLVM: %[[BASE_ADDR:.*]] = alloca ptr, i64 1 -! LLVM: store ptr null, ptr %[[BASE_ADDR]] -! LLVM: %[[LOAD_BASE_ADDR:.*]] = load ptr, ptr %[[BASE_ADDR]] -! LLVM: %[[BOX0:.*]] = insertvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } { ptr undef, i64 ptrtoint (ptr getelementptr (%_QMpolyTp1, ptr null, i32 1) to i64), i32 20180515, i8 0, i8 42, i8 2, i8 1, ptr @_QMpolyE.dt.p1, [1 x i64] undef }, ptr %[[LOAD_BASE_ADDR]], 0 -! LLVM: store { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[BOX0]], ptr %[[ALLOCA4]] -! LLVM: %[[LOAD:.*]] = load { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] }, ptr %[[ALLOCA4]] -! LLVM: store { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[LOAD]], ptr %[[DESC]] -! LLVM: %{{.*}} = call {} @_FortranAAllocatableInitDerived(ptr %[[DESC]], ptr @_QMpolyE.dt.p1, i32 0, i32 0) -! LLVM: %{{.*}} = call i32 @_FortranAAllocatableAllocate(ptr %[[DESC]], i1 false, ptr null, ptr @_QQcl.{{.*}}, i32 {{.*}}) -! LLVM: %[[LOAD_DESC:.*]] = load { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] }, ptr %[[DESC]] -! LLVM: store { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[LOAD_DESC]], ptr %[[ALLOCA3]] -! LLVM: %[[BASE_ADDR_GEP:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] }, ptr %[[ALLOCA3]], i32 0, i32 0 -! LLVM: %[[LOAD_BASE_ADDR:.*]] = load ptr, ptr %[[BASE_ADDR_GEP]] -! LLVM: store ptr %[[LOAD_BASE_ADDR]], ptr %[[BASE_ADDR]] -! LLVM: %[[LOAD_BASE_ADDR:.*]] = load ptr, ptr %[[BASE_ADDR]] -! LLVM: %[[BOX0:.*]] = insertvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } { ptr undef, i64 ptrtoint (ptr getelementptr (%_QMpolyTp1, ptr null, i32 1) to i64), i32 20180515, i8 0, i8 42, i8 2, i8 1, ptr @_QMpolyE.dt.p1, [1 x i64] undef }, ptr %[[LOAD_BASE_ADDR]], 0 -! LLVM: store { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[BOX0]], ptr %[[ALLOCA2]] -! LLVM: %[[LOAD:.*]] = load { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] }, ptr %[[ALLOCA2]] -! LLVM: store { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[LOAD]], ptr %[[DESC]] -! LLVM: %{{.*}} = call i32 @_FortranAAllocatableDeallocate(ptr %[[DESC]], i1 false, ptr null, ptr @_QQcl.{{.*}}, i32 {{.*}}) -! LLVM: %[[LOAD_DESC:.*]] = load { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] }, ptr %[[DESC]] -! LLVM: store { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[LOAD_DESC]], ptr %[[ALLOCA1]] -! LLVM: %[[BASE_ADDR_GEP:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] }, ptr %1, i32 0, i32 0 -! LLVM: %[[LOAD_BASE_ADDR:.*]] = load ptr, ptr %[[BASE_ADDR_GEP]] -! LLVM: store ptr %[[LOAD_BASE_ADDR]], ptr %[[BASE_ADDR]] -! LLVM: ret void +! LLVM: %[[ALLOCA2:.*]] = alloca { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] }, i64 1 +! LLVM: store { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } { ptr null, i64 ptrtoint (ptr getelementptr (%_QMpolyTp1, ptr null, i32 1) to i64), i32 20180515, i8 0, i8 42, i8 2, i8 1, ptr @_QMpolyE.dt.p1, [1 x i64] undef }, ptr %[[ALLOCA1]] +! LLVM: %[[LOAD:.*]] = load { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] }, ptr %[[ALLOCA1]] +! LLVM: store { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[LOAD]], ptr %[[ALLOCA2]] +! LLVM: %{{.*}} = call {} @_FortranAAllocatableInitDerived(ptr %[[ALLOCA2]], ptr @_QMpolyE.dt.p1, i32 0, i32 0) +! LLVM: %{{.*}} = call i32 @_FortranAAllocatableAllocate(ptr %[[ALLOCA2]], i1 false, ptr null, ptr @_QQcl.{{.*}}, i32 {{.*}}) +! LLVM: %{{.*}} = call i32 @_FortranAAllocatableDeallocate(ptr %[[ALLOCA2]], i1 false, ptr null, ptr @_QQcl.{{.*}}, i32 {{.*}}) diff --git a/flang/test/Lower/nullify-polymoprhic.f90 b/flang/test/Lower/nullify-polymoprhic.f90 --- a/flang/test/Lower/nullify-polymoprhic.f90 +++ b/flang/test/Lower/nullify-polymoprhic.f90 @@ -43,7 +43,6 @@ ! CHECK-LABEL: func.func @_QMpolyPtest_nullify() ! CHECK: %[[C_DESC:.*]] = fir.alloca !fir.class>> {bindc_name = "c", uniq_name = "_QMpolyFtest_nullifyEc"} -! CHECK: %[[C_ADDR:.*]] = fir.alloca !fir.ptr> {uniq_name = "_QMpolyFtest_nullifyEc.addr"} ! CHECK: %{{.*}} = fir.call @_FortranAPointerAllocate(%{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 ! CHECK: %[[DECLARED_TYPE:.*]] = fir.address_of(@_QMpolyE.dt.p1) : !fir.ref> ! CHECK: %[[C_DESC_CAST:.*]] = fir.convert %[[C_DESC]] : (!fir.ref>>>) -> !fir.ref> diff --git a/flang/test/Lower/pointer-association-polymorphic.f90 b/flang/test/Lower/pointer-association-polymorphic.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/pointer-association-polymorphic.f90 @@ -0,0 +1,175 @@ +! RUN: bbc -polymorphic-type -emit-fir %s -o - | FileCheck %s + +module poly + type p1 + integer :: a + integer :: b + contains + procedure :: proc => proc_p1 + end type + + type, extends(p1) :: p2 + integer :: c + contains + procedure :: proc => proc_p2 + end type + +contains + + subroutine proc_p1(this) + class(p1) :: this + print*, 'call proc2_p1' + end subroutine + + subroutine proc_p2(this) + class(p2) :: this + print*, 'call proc2_p2' + end subroutine + + +! ------------------------------------------------------------------------------ +! Test lowering of ALLOCATE statement for polymoprhic pointer +! ------------------------------------------------------------------------------ + + subroutine test_pointer() + class(p1), pointer :: p + class(p1), allocatable, target :: c1, c2 + class(p1), pointer :: pa(:) + class(p1), allocatable, target, dimension(:) :: c3, c4 + integer :: i + + allocate(p1::c1) + allocate(p2::c2) + allocate(p1::c3(2)) + allocate(p2::c4(4)) + + p => c1 + call p%proc() + + p => c2 + call p%proc() + + p => c3(1) + call p%proc() + + p => c4(2) + call p%proc() + + pa => c3 + do i = 1, 2 + call pa(i)%proc() + end do + + pa => c4 + do i = 1, 4 + call pa(i)%proc() + end do + + pa => c4(2:4) + do i = 1, 2 + call pa(i)%proc() + end do + + deallocate(c1) + deallocate(c2) + deallocate(c3) + deallocate(c4) + end subroutine + +! CHECK-LABEL: func.func @_QMpolyPtest_pointer() +! CHECK-DAG: %[[C1_DESC:.*]] = fir.alloca !fir.class>> {bindc_name = "c1", fir.target, uniq_name = "_QMpolyFtest_pointerEc1"} +! CHECK-DAG: %[[C2_DESC:.*]] = fir.alloca !fir.class>> {bindc_name = "c2", fir.target, uniq_name = "_QMpolyFtest_pointerEc2"} +! CHECK-DAG: %[[C3_DESC:.*]] = fir.alloca !fir.class>>> {bindc_name = "c3", fir.target, uniq_name = "_QMpolyFtest_pointerEc3"} +! CHECK-DAG: %[[C4_DESC:.*]] = fir.alloca !fir.class>>> {bindc_name = "c4", fir.target, uniq_name = "_QMpolyFtest_pointerEc4"} +! CHECK-DAG: %[[P_DESC:.*]] = fir.alloca !fir.class>> {bindc_name = "p", uniq_name = "_QMpolyFtest_pointerEp"} +! CHECK-DAG: %[[PA_DESC:.*]] = fir.alloca !fir.class>>> {bindc_name = "pa", uniq_name = "_QMpolyFtest_pointerEpa"} + +! CHECK: %[[C1_DESC_LOAD:.*]] = fir.load %[[C1_DESC]] : !fir.ref>>> +! CHECK: %[[C1_REBOX:.*]] = fir.rebox %[[C1_DESC_LOAD]] : (!fir.class>>) -> !fir.class>> +! CHECK: fir.store %[[C1_REBOX]] to %[[P_DESC]] : !fir.ref>>> +! CHECK: %[[P_DESC_LOAD:.*]] = fir.load %[[P_DESC]] : !fir.ref>>> +! CHECK: %[[P_REBOX:.*]] = fir.rebox %[[P_DESC_LOAD]] : (!fir.class>>) -> !fir.class> +! CHECK: fir.dispatch "proc"(%[[P_REBOX]] : !fir.class>) (%[[P_REBOX]] : !fir.class>) {pass_arg_pos = 0 : i32} + +! CHECK: %[[C2_DESC_LOAD:.*]] = fir.load %[[C2_DESC]] : !fir.ref>>> +! CHECK: %[[C2_REBOX:.*]] = fir.rebox %[[C2_DESC_LOAD]] : (!fir.class>>) -> !fir.class>> +! CHECK: fir.store %[[C2_REBOX]] to %[[P_DESC]] : !fir.ref>>> +! CHECK: %[[P_DESC_LOAD:.*]] = fir.load %[[P_DESC]] : !fir.ref>>> +! CHECK: %[[P_REBOX:.*]] = fir.rebox %[[P_DESC_LOAD]] : (!fir.class>>) -> !fir.class> +! CHECK: fir.dispatch "proc"(%[[P_REBOX]] : !fir.class>) (%[[P_REBOX]] : !fir.class>) {pass_arg_pos = 0 : i32} + +! CHECK: %[[C3_LOAD:.*]] = fir.load %[[C3_DESC]] : !fir.ref>>>> +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[C3_DIMS:.*]]:3 = fir.box_dims %[[C3_LOAD]], %[[C0]] : (!fir.class>>>, index) -> (index, index, index) +! CHECK: %[[C1:.*]] = arith.constant 1 : i64 +! CHECK: %[[LB:.*]] = fir.convert %[[C3_DIMS]]#0 : (index) -> i64 +! CHECK: %[[IDX:.*]] = arith.subi %[[C1]], %[[LB]] : i64 +! CHECK: %[[C3_COORD:.*]] = fir.coordinate_of %[[C3_LOAD]], %[[IDX]] : (!fir.class>>>, i64) -> !fir.ref> +! CHECK: %[[C3_TDESC:.*]] = fir.box_tdesc %[[C3_LOAD]] : (!fir.class>>>) -> !fir.tdesc +! CHECK: %[[C3_EMBOX:.*]] = fir.embox %[[C3_COORD]] tdesc %[[C3_TDESC]] : (!fir.ref>, !fir.tdesc) -> !fir.class>> +! CHECK: fir.store %[[C3_EMBOX]] to %[[P_DESC]] : !fir.ref>>> +! CHECK: %[[P_DESC_LOAD:.*]] = fir.load %[[P_DESC]] : !fir.ref>>> +! CHECK: %[[P_REBOX:.*]] = fir.rebox %[[P_DESC_LOAD]] : (!fir.class>>) -> !fir.class> +! CHECK: fir.dispatch "proc"(%[[P_REBOX]] : !fir.class>) (%[[P_REBOX]] : !fir.class>) {pass_arg_pos = 0 : i32} + +! CHECK: %[[C4_LOAD:.*]] = fir.load %[[C4_DESC]] : !fir.ref>>>> +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[C4_DIMS:.*]]:3 = fir.box_dims %[[C4_LOAD]], %[[C0]] : (!fir.class>>>, index) -> (index, index, index) +! CHECK: %[[C2:.*]] = arith.constant 2 : i64 +! CHECK: %[[LB:.*]] = fir.convert %[[C4_DIMS]]#0 : (index) -> i64 +! CHECK: %[[IDX:.*]] = arith.subi %[[C2]], %[[LB]] : i64 +! CHECK: %[[C4_COORD:.*]] = fir.coordinate_of %[[C4_LOAD]], %[[IDX]] : (!fir.class>>>, i64) -> !fir.ref> +! CHECK: %[[C4_TDESC:.*]] = fir.box_tdesc %[[C4_LOAD]] : (!fir.class>>>) -> !fir.tdesc +! CHECK: %[[C4_EMBOX:.*]] = fir.embox %[[C4_COORD]] tdesc %[[C4_TDESC]] : (!fir.ref>, !fir.tdesc) -> !fir.class>> +! CHECK: fir.store %[[C4_EMBOX]] to %[[P_DESC]] : !fir.ref>>> +! CHECK: %[[P_DESC_LOAD:.*]] = fir.load %[[P_DESC]] : !fir.ref>>> +! CHECK: %[[P_REBOX:.*]] = fir.rebox %[[P_DESC_LOAD]] : (!fir.class>>) -> !fir.class> +! CHECK: fir.dispatch "proc"(%[[P_REBOX]] : !fir.class>) (%[[P_REBOX]] : !fir.class>) {pass_arg_pos = 0 : i32} + +! CHECK: %[[C3_LOAD:.*]] = fir.load %[[C3_DESC]] : !fir.ref>>>> +! CHECK: %[[C3_REBOX:.*]] = fir.rebox %[[C3_LOAD]](%{{.*}}) : (!fir.class>>>, !fir.shift<1>) -> !fir.class>>> +! CHECK: fir.store %[[C3_REBOX]] to %[[PA_DESC]] : !fir.ref>>>> +! CHECK-LABEL: fir.do_loop +! CHECK: %[[PA_LOAD:.*]] = fir.load %[[PA_DESC]] : !fir.ref>>>> +! CHECK: %[[PA_COORD:.*]] = fir.coordinate_of %[[PA_LOAD]], %{{.*}} : (!fir.class>>>, i64) -> !fir.ref> +! CHECK: %[[PA_TDESC:.*]] = fir.box_tdesc %[[PA_LOAD]] : (!fir.class>>>) -> !fir.tdesc +! CHECK: %[[PA_EMBOX:.*]] = fir.embox %[[PA_COORD]] tdesc %[[PA_TDESC]] : (!fir.ref>, !fir.tdesc) -> !fir.class> +! CHECK: fir.dispatch "proc"(%[[PA_EMBOX]] : !fir.class>) (%[[PA_EMBOX]] : !fir.class>) {pass_arg_pos = 0 : i32} + +! CHECK: %[[C4_LOAD:.*]] = fir.load %[[C4_DESC]] : !fir.ref>>>> +! CHECK: %[[C4_REBOX:.*]] = fir.rebox %[[C4_LOAD]](%{{.*}}) : (!fir.class>>>, !fir.shift<1>) -> !fir.class>>> +! CHECK: fir.store %[[C4_REBOX]] to %[[PA_DESC]] : !fir.ref>>>> +! CHECK-LABEL: fir.do_loop +! CHECK: %[[PA_LOAD:.*]] = fir.load %[[PA_DESC]] : !fir.ref>>>> +! CHECK: %[[PA_COORD:.*]] = fir.coordinate_of %[[PA_LOAD]], %{{.*}} : (!fir.class>>>, i64) -> !fir.ref> +! CHECK: %[[PA_TDESC:.*]] = fir.box_tdesc %[[PA_LOAD]] : (!fir.class>>>) -> !fir.tdesc +! CHECK: %[[PA_EMBOX:.*]] = fir.embox %[[PA_COORD]] tdesc %[[PA_TDESC]] : (!fir.ref>, !fir.tdesc) -> !fir.class> +! CHECK: fir.dispatch "proc"(%[[PA_EMBOX]] : !fir.class>) (%[[PA_EMBOX]] : !fir.class>) {pass_arg_pos = 0 : i32} + +! CHECK: %[[C4_LOAD:.*]] = fir.load %[[C4_DESC]] : !fir.ref>>>> +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[C4_DIMS:.*]]:3 = fir.box_dims %[[C4_LOAD]], %[[C0]] : (!fir.class>>>, index) -> (index, index, index) +! CHECK: %[[C2:.*]] = arith.constant 2 : i64 +! CHECK: %[[C2_INDEX:.*]] = fir.convert %[[C2]] : (i64) -> index +! CHECK: %[[C1:.*]] = arith.constant 1 : i64 +! CHECK: %[[C1_INDEX:.*]] = fir.convert %[[C1]] : (i64) -> index +! CHECK: %[[C4:.*]] = arith.constant 4 : i64 +! CHECK: %[[C4_INDEX:.*]] = fir.convert %[[C4]] : (i64) -> index +! CHECK: %[[SHIFT:.*]] = fir.shift %[[C4_DIMS]]#0 : (index) -> !fir.shift<1> +! CHECK: %[[SLICE:.*]] = fir.slice %[[C2_INDEX]], %[[C4_INDEX]], %[[C1_INDEX]] : (index, index, index) -> !fir.slice<1> +! CHECK: %[[SLICE_REBOX:.*]] = fir.rebox %[[C4_LOAD]](%[[SHIFT]]) [%[[SLICE]]] : (!fir.class>>>, !fir.shift<1>, !fir.slice<1>) -> !fir.class>> +! CHECK: %[[PTR_REBOX:.*]] = fir.rebox %[[SLICE_REBOX]] : (!fir.class>>) -> !fir.class>>> +! CHECK: fir.store %[[PTR_REBOX]] to %[[PA_DESC]] : !fir.ref>>>> +! CHECK-LABEL: fir.do_loop +! CHECK: %[[PA_LOAD:.*]] = fir.load %[[PA_DESC]] : !fir.ref>>>> +! CHECK: %[[PA_COORD:.*]] = fir.coordinate_of %[[PA_LOAD]], %{{.*}} : (!fir.class>>>, i64) -> !fir.ref> +! CHECK: %[[PA_TDESC:.*]] = fir.box_tdesc %[[PA_LOAD]] : (!fir.class>>>) -> !fir.tdesc +! CHECK: %[[PA_EMBOX:.*]] = fir.embox %[[PA_COORD]] tdesc %[[PA_TDESC]] : (!fir.ref>, !fir.tdesc) -> !fir.class> +! CHECK: fir.dispatch "proc"(%[[PA_EMBOX]] : !fir.class>) (%[[PA_EMBOX]] : !fir.class>) {pass_arg_pos = 0 : i32} + +end module + +program test_pointer_association + use poly + call test_pointer() +end