diff --git a/flang/include/flang/Optimizer/Builder/BoxValue.h b/flang/include/flang/Optimizer/Builder/BoxValue.h --- a/flang/include/flang/Optimizer/Builder/BoxValue.h +++ b/flang/include/flang/Optimizer/Builder/BoxValue.h @@ -32,6 +32,7 @@ class CharBoxValue; class CharArrayBoxValue; class MutableBoxValue; +class PolymorphicValue; class ProcBoxValue; llvm::raw_ostream &operator<<(llvm::raw_ostream &, const CharBoxValue &); @@ -40,6 +41,7 @@ llvm::raw_ostream &operator<<(llvm::raw_ostream &, const ProcBoxValue &); llvm::raw_ostream &operator<<(llvm::raw_ostream &, const MutableBoxValue &); llvm::raw_ostream &operator<<(llvm::raw_ostream &, const BoxValue &); +llvm::raw_ostream &operator<<(llvm::raw_ostream &, const PolymorphicValue &); //===----------------------------------------------------------------------===// // @@ -96,6 +98,24 @@ mlir::Value len; }; +/// Polymorphic value associated with a dynamic type descriptor. +class PolymorphicValue : public AbstractBox { +public: + PolymorphicValue(mlir::Value addr, mlir::Value tdesc) + : AbstractBox{addr}, tdesc{tdesc} {} + + PolymorphicValue clone(mlir::Value newBase) const { return {newBase, tdesc}; } + + mlir::Value getTdesc() const { return tdesc; } + + friend llvm::raw_ostream &operator<<(llvm::raw_ostream &, + const PolymorphicValue &); + LLVM_DUMP_METHOD void dump() const { llvm::errs() << *this; } + +protected: + mlir::Value tdesc; +}; + /// Abstract base class. /// Expressions of type array have at minimum a shape. These expressions may /// have lbound attributes (dynamic values) that affect the interpretation of @@ -456,7 +476,7 @@ public: using VT = std::variant; + ProcBoxValue, BoxValue, MutableBoxValue, PolymorphicValue>; ExtendedValue() : box{UnboxedValue{}} {} template unsigned { return 0; }, [](const fir::CharBoxValue &box) -> unsigned { return 0; }, [](const fir::ProcBoxValue &box) -> unsigned { return 0; }, + [](const fir::PolymorphicValue &box) -> unsigned { return 0; }, [](const auto &box) -> unsigned { return box.rank(); }); } diff --git a/flang/lib/Frontend/CompilerInvocation.cpp b/flang/lib/Frontend/CompilerInvocation.cpp --- a/flang/lib/Frontend/CompilerInvocation.cpp +++ b/flang/lib/Frontend/CompilerInvocation.cpp @@ -869,4 +869,5 @@ // Lower TRANSPOSE as a runtime call under -O0. loweringOpts.setOptimizeTranspose(codegenOpts.OptimizationLevel > 0); + loweringOpts.setPolymorphicTypeImpl(true); } 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 @@ -1106,6 +1106,9 @@ fir::emitFatalError(loc, "derived type components must not be " "represented by fir::BoxValue"); }, + [&](const fir::PolymorphicValue &) { + TODO(loc, "polymorphic component in derived type assignment"); + }, [&](const fir::MutableBoxValue &toBox) { if (toBox.isPointer()) { Fortran::lower::associateMutableBox( diff --git a/flang/lib/Optimizer/Builder/BoxValue.cpp b/flang/lib/Optimizer/Builder/BoxValue.cpp --- a/flang/lib/Optimizer/Builder/BoxValue.cpp +++ b/flang/lib/Optimizer/Builder/BoxValue.cpp @@ -84,6 +84,12 @@ << " }"; } +llvm::raw_ostream &fir::operator<<(llvm::raw_ostream &os, + const fir::PolymorphicValue &p) { + return os << "polymorphicvalue: { addr: " << p.getAddr() + << ", tdesc: " << p.getTdesc() << " }"; +} + llvm::raw_ostream &fir::operator<<(llvm::raw_ostream &os, const fir::ArrayBoxValue &box) { os << "boxarray { addr: " << box.getAddr(); diff --git a/flang/lib/Optimizer/Builder/FIRBuilder.cpp b/flang/lib/Optimizer/Builder/FIRBuilder.cpp --- a/flang/lib/Optimizer/Builder/FIRBuilder.cpp +++ b/flang/lib/Optimizer/Builder/FIRBuilder.cpp @@ -527,6 +527,12 @@ return create( loc, fir::factory::getMutableIRBox(*this, loc, x)); }, + [&](const fir::PolymorphicValue &p) -> mlir::Value { + mlir::Value empty; + mlir::ValueRange emptyRange; + return create(loc, boxTy, itemAddr, empty, empty, + emptyRange, p.getTdesc()); + }, [&](const auto &) -> mlir::Value { mlir::Value empty; mlir::ValueRange emptyRange; 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 @@ -419,6 +419,13 @@ } if (rank) return fir::ArrayBoxValue{addr, extents, lbounds}; + if (box.isPolymorphic()) { + auto loadedBox = builder.create(loc, box.getAddr()); + mlir::Type tdescType = + fir::TypeDescType::get(mlir::NoneType::get(builder.getContext())); + auto tdesc = builder.create(loc, tdescType, loadedBox); + return fir::PolymorphicValue(addr, tdesc); + } return addr; } @@ -467,6 +474,10 @@ mlir::ValueRange lbounds) { MutablePropertyWriter writer(builder, loc, box); source.match( + [&](const fir::PolymorphicValue &p) { + writer.updateMutableBox(p.getAddr(), /*lbounds=*/llvm::None, + /*extents=*/llvm::None, /*lengths=*/llvm::None); + }, [&](const fir::UnboxedValue &addr) { writer.updateMutableBox(addr, /*lbounds=*/llvm::None, /*extents=*/llvm::None, /*lengths=*/llvm::None); @@ -566,6 +577,10 @@ }; MutablePropertyWriter writer(builder, loc, box); source.match( + [&](const fir::PolymorphicValue &p) { + writer.updateMutableBox(cast(p.getAddr()), lbounds, extents, + /*lengths=*/llvm::None); + }, [&](const fir::UnboxedValue &addr) { writer.updateMutableBox(cast(addr), lbounds, extents, /*lengths=*/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 @@ -40,17 +40,33 @@ class(p1), pointer :: p class(p1), pointer :: c1, c2 class(p1), pointer, dimension(:) :: c3, c4 + integer :: i print*, 'test allocation of polymorphic pointers' allocate(p) + call p%proc1() allocate(p1::c1) allocate(p2::c2) + call c1%proc1() + call c2%proc1() + + call c1%proc2() + call c2%proc2() + allocate(p1::c3(10)) allocate(p2::c4(20)) + do i = 1, 10 + call c3(i)%proc2() + end do + + do i = 1, 20 + call c4(i)%proc2() + end do + end subroutine ! CHECK-LABEL: func.func @_QMpolyPtest_pointer() @@ -99,6 +115,28 @@ ! 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>> +! CHECK: fir.dispatch "proc1"(%[[C1_DESC_CAST]] : !fir.class>>) + +! call c2%proc1() +! CHECK: %[[C2_DESC_CAST:.*]] = fir.convert %[[C2_DESC]] : (!fir.ref>>>) -> !fir.class>> +! 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} + +! 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: %[[TYPE_DESC_P1:.*]] = fir.address_of(@_QMpolyE.dt.p1) : !fir.ref> ! CHECK: %[[C3_CAST:.*]] = fir.convert %[[C3_DESC]] : (!fir.ref>>>>) -> !fir.ref> ! CHECK: %[[TYPE_DESC_P1_CAST:.*]] = fir.convert %[[TYPE_DESC_P1]] : (!fir.ref>) -> !fir.ref @@ -121,6 +159,19 @@ ! CHECK: %[[C4_CAST:.*]] = fir.convert %[[C4_DESC]] : (!fir.ref>>>>) -> !fir.ref> ! CHECK: %{{.*}} = fir.call @_FortranAPointerAllocate(%[[C4_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK-LABEL: fir.do_loop +! 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_BOXED:.*]] = fir.embox %[[C3_COORD]] tdesc %[[C3_TDESC]] : (!fir.ref>, !fir.tdesc>) -> !fir.class> +! CHECK: fir.dispatch "proc2"(%[[C3_BOXED]] : !fir.class>) (%[[C3_BOXED]] : !fir.class>) {pass_arg_pos = 0 : i32} + +! CHECK-LABEL: fir.do_loop +! CHECK: %[[C4_LOAD:.*]] = fir.load %[[C4_DESC]] : !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_BOXED:.*]] = fir.embox %[[C4_COORD]] tdesc %[[C4_TDESC]] : (!fir.ref>, !fir.tdesc>) -> !fir.class> +! CHECK: fir.dispatch "proc2"(%[[C4_BOXED]] : !fir.class>) (%[[C4_BOXED]] : !fir.class>) {pass_arg_pos = 0 : i32} end module