diff --git a/flang/docs/PolymorphicEntities.md b/flang/docs/PolymorphicEntities.md --- a/flang/docs/PolymorphicEntities.md +++ b/flang/docs/PolymorphicEntities.md @@ -683,14 +683,15 @@ **FIR** ```c -%0 = fir.alloca !fir.class,base:f32,height:f32>> -%1 = fir.alloca !fir.class,base:f32,height:f32}>> -%3 = fir.convert %0 : (!fir.ref,base:f32,height:f32>>>) -> !fir.ref> -%4 = fir.gentypedesc !fir.type<_QMgeometryTtriangle{color:i32,isFilled:!fir.logical<4>,base:f32,height:f32}>> -%5 = fir.call @_FortranAAllocatableInitDerived(%3, %4) +%0 = fir.address_of(@_QMgeometryE.dt.triangle) : !fir.ref> +%1 = fir.convert %item1 : (!fir.ref,base:f32,height:f32>>>) -> !fir.ref> +%2 = fir.call @_FortranAAllocatableInitDerived(%1, %0) +%3 = fir.call @_FortranAAllocatableAllocate(%1, ...) -%6 = fir.convert %1 : (!fir.ref,base:f32,height:f32}>>>) -> !fir.ref> -%7 = fir.gentypedesc !fir.type<_QMgeometryTtriangle{color:i32,isFilled:!fir.logical<4>,base:f32,height:f32}>> %8 = fir.call @_FortranAAllocatableInitDerived(%6, %7) +%4 = fir.address_of(@_QMgeometryE.dt.rectangle) : !fir.ref> +%5 = fir.convert %item2 : (!fir.ref,base:f32,height:f32}>>>) -> !fir.ref> +%6 = fir.call @_FortranAAllocatableInitDerived(%5, %4) +%7 = fir.call @_FortranAAllocatableAllocate(%5, ...) ``` For pointer allocation, the `PointerAllocate` function is used. @@ -851,7 +852,6 @@ Current list of TODOs in lowering: - `flang/lib/Lower/Allocatable.cpp:465` not yet implemented: SOURCE allocation - `flang/lib/Lower/Allocatable.cpp:468` not yet implemented: MOLD allocation -- `flang/lib/Lower/Allocatable.cpp:471` not yet implemented: polymorphic entity allocation - `flang/lib/Lower/Bridge.cpp:448` not yet implemented: create polymorphic host associated copy - `flang/lib/Lower/Bridge.cpp:2185` not yet implemented: assignment to polymorphic allocatable - `flang/lib/Lower/Bridge.cpp:2288` not yet implemented: pointer assignment involving polymorphic entity diff --git a/flang/include/flang/Optimizer/Builder/Runtime/RTBuilder.h b/flang/include/flang/Optimizer/Builder/Runtime/RTBuilder.h --- a/flang/include/flang/Optimizer/Builder/Runtime/RTBuilder.h +++ b/flang/include/flang/Optimizer/Builder/Runtime/RTBuilder.h @@ -35,7 +35,10 @@ namespace Fortran::runtime { class Descriptor; +namespace typeInfo { +class DerivedType; } +} // namespace Fortran::runtime namespace fir::runtime { @@ -280,6 +283,13 @@ }; } template <> +constexpr TypeBuilderFunc +getModel() { + return [](mlir::MLIRContext *context) -> mlir::Type { + return fir::ReferenceType::get(mlir::NoneType::get(context)); + }; +} +template <> constexpr TypeBuilderFunc getModel() { return [](mlir::MLIRContext *context) -> mlir::Type { return mlir::NoneType::get(context); 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 @@ -14,6 +14,7 @@ #include "flang/Evaluate/tools.h" #include "flang/Lower/AbstractConverter.h" #include "flang/Lower/IterationSpace.h" +#include "flang/Lower/Mangler.h" #include "flang/Lower/PFTBuilder.h" #include "flang/Lower/Runtime.h" #include "flang/Lower/StatementContext.h" @@ -23,6 +24,7 @@ #include "flang/Optimizer/Dialect/FIROps.h" #include "flang/Optimizer/Dialect/FIROpsSupport.h" #include "flang/Optimizer/Support/FatalError.h" +#include "flang/Optimizer/Support/InternalNames.h" #include "flang/Parser/parse-tree.h" #include "flang/Runtime/allocatable.h" #include "flang/Runtime/pointer.h" @@ -393,7 +395,7 @@ if (alloc.hasCoarraySpec()) TODO(loc, "coarray allocation"); if (alloc.type.IsPolymorphic()) - genSetType(alloc, box); + genSetType(alloc, box, loc); genSetDeferredLengthParameters(alloc, box); // Set bounds for arrays mlir::Type idxTy = builder.getIndexType(); @@ -467,8 +469,47 @@ void genMoldAllocation(const Allocation &, const fir::MutableBoxValue &) { TODO(loc, "MOLD allocation"); } - void genSetType(const Allocation &, const fir::MutableBoxValue &) { - TODO(loc, "polymorphic entity allocation"); + + /// Generate call to the AllocatableInitDerived to set up the type descriptor + /// and other part of the descriptor for derived type. + void genSetType(const Allocation &alloc, const fir::MutableBoxValue &box, + mlir::Location loc) { + const Fortran::semantics::DeclTypeSpec *typeSpec = + getIfAllocateStmtTypeSpec(); + + // No type spec provided in allocate statement so the declared type spec is + // used. + if (!typeSpec) + typeSpec = &alloc.type; + + assert(typeSpec && "type spec missing for polymorphic allocation"); + std::string typeName = + Fortran::lower::mangle::mangleName(typeSpec->derivedTypeSpec()); + std::string typeDescName = + fir::NameUniquer::getTypeDescriptorName(typeName); + + auto typeDescGlobal = + builder.getModule().lookupSymbol(typeDescName); + if (!typeDescGlobal) + fir::emitFatalError(loc, "type descriptor not defined"); + auto typeDescAddr = builder.create( + loc, fir::ReferenceType::get(typeDescGlobal.getType()), + typeDescGlobal.getSymbol()); + mlir::func::FuncOp callee = + fir::runtime::getRuntimeFunc(loc, + builder); + + llvm::ArrayRef inputTypes = + callee.getFunctionType().getInputs(); + llvm::SmallVector args; + args.push_back(builder.createConvert(loc, inputTypes[0], box.getAddr())); + args.push_back(builder.createConvert(loc, inputTypes[1], typeDescAddr)); + mlir::Value rank = builder.createIntegerConstant(loc, inputTypes[2], + alloc.getSymbol().Rank()); + mlir::Value c0 = builder.createIntegerConstant(loc, inputTypes[3], 0); + args.push_back(rank); + args.push_back(c0); + builder.create(loc, callee, args); } /// Returns a pointer to the DeclTypeSpec if a type-spec is provided in the diff --git a/flang/lib/Optimizer/CodeGen/CodeGen.cpp b/flang/lib/Optimizer/CodeGen/CodeGen.cpp --- a/flang/lib/Optimizer/CodeGen/CodeGen.cpp +++ b/flang/lib/Optimizer/CodeGen/CodeGen.cpp @@ -2753,7 +2753,7 @@ matchAndRewrite(fir::GlobalOp global, OpAdaptor adaptor, mlir::ConversionPatternRewriter &rewriter) const override { auto tyAttr = convertType(global.getType()); - if (global.getType().isa()) + if (global.getType().isa()) tyAttr = tyAttr.cast().getElementType(); auto loc = global.getLoc(); mlir::Attribute initAttr = global.getInitVal().value_or(mlir::Attribute()); diff --git a/flang/lib/Optimizer/CodeGen/TypeConverter.h b/flang/lib/Optimizer/CodeGen/TypeConverter.h --- a/flang/lib/Optimizer/CodeGen/TypeConverter.h +++ b/flang/lib/Optimizer/CodeGen/TypeConverter.h @@ -118,7 +118,7 @@ for (auto mem : tuple.getTypes()) { // Prevent fir.box from degenerating to a pointer to a descriptor in the // context of a tuple type. - if (auto box = mem.dyn_cast()) + if (auto box = mem.dyn_cast()) members.push_back(convertBoxTypeAsStruct(box)); else members.push_back(convertType(mem).cast()); @@ -177,7 +177,7 @@ for (auto mem : derived.getTypeList()) { // Prevent fir.box from degenerating to a pointer to a descriptor in the // context of a record type. - if (auto box = mem.second.dyn_cast()) + if (auto box = mem.second.dyn_cast()) members.push_back(convertBoxTypeAsStruct(box)); else members.push_back(convertType(mem.second).cast()); @@ -269,7 +269,7 @@ /// Convert fir.box type to the corresponding llvm struct type instead of a /// pointer to this struct type. - mlir::Type convertBoxTypeAsStruct(BoxType box) { + mlir::Type convertBoxTypeAsStruct(BaseBoxType box) { return convertBoxType(box) .cast() .getElementType(); @@ -331,7 +331,7 @@ // the same as a fir.box at the LLVM level. // The distinction is kept in fir to denote when a descriptor is expected // to be mutable (fir.ref) and when it is not (fir.box). - if (eleTy.isa()) + if (eleTy.isa()) return convertType(eleTy); return mlir::LLVM::LLVMPointerType::get(convertType(eleTy)); diff --git a/flang/test/Lower/allocatable-polymorphic.f90 b/flang/test/Lower/allocatable-polymorphic.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/allocatable-polymorphic.f90 @@ -0,0 +1,116 @@ +! RUN: bbc -polymorphic-type -emit-fir %s -o - | FileCheck %s +! RUN: bbc -polymorphic-type -emit-fir %s -o - | tco | FileCheck %s --check-prefix=LLVM + +module poly + type p1 + integer :: a + integer :: b + end type + + type, extends(p1) :: p2 + integer :: c + end type +end module + +program test_allocatable + use poly + + class(p1), allocatable :: p + class(p1), allocatable :: c1, c2 + class(p1), allocatable, dimension(:) :: c3, c4 + + allocate(p) ! allocate as p1 + + allocate(p1::c1) + allocate(p2::c2) + + allocate(p1::c3(10)) + allocate(p2::c4(20)) + +end + +! CHECK-LABEL: func.func @_QQmain() + +! CHECK-DAG: %[[C1:.*]] = fir.address_of(@_QFEc1) : !fir.ref>>> +! CHECK-DAG: %[[C2:.*]] = fir.address_of(@_QFEc2) : !fir.ref>>> +! CHECK-DAG: %[[C3:.*]] = fir.address_of(@_QFEc3) : !fir.ref>>>> +! CHECK-DAG: %[[C4:.*]] = fir.address_of(@_QFEc4) : !fir.ref>>>> +! CHECK-DAG: %[[P:.*]] = fir.address_of(@_QFEp) : !fir.ref>>> + +! CHECK: %[[TYPE_DESC_P1:.*]] = fir.address_of(@_QMpolyE.dt.p1) : !fir.ref>>>) -> !fir.ref> +! CHECK: %[[TYPE_DESC_P1_CAST:.*]] = fir.convert %[[TYPE_DESC_P1]] : (!fir.ref>, !fir.ref, i32, i32) -> none +! CHECK: %[[P_CAST:.*]] = fir.convert %[[P]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %{{.*}} = fir.call @_FortranAAllocatableAllocate(%[[P_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 + +! CHECK: %[[TYPE_DESC_P1:.*]] = fir.address_of(@_QMpolyE.dt.p1) : !fir.ref>>>) -> !fir.ref> +! CHECK: %[[TYPE_DESC_P1_CAST:.*]] = fir.convert %[[TYPE_DESC_P1]] : (!fir.ref>, !fir.ref, i32, i32) -> none +! CHECK: %[[C1_CAST:.*]] = fir.convert %[[C1]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %{{.*}} = fir.call @_FortranAAllocatableAllocate(%[[C1_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 + +! CHECK: %[[TYPE_DESC_P2:.*]] = fir.address_of(@_QMpolyE.dt.p2) : !fir.ref>>>) -> !fir.ref> +! CHECK: %[[TYPE_DESC_P2_CAST:.*]] = fir.convert %[[TYPE_DESC_P2]] : (!fir.ref>, !fir.ref, i32, i32) -> none +! CHECK: %[[C2_CAST:.*]] = fir.convert %[[C2]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %{{.*}} = fir.call @_FortranAAllocatableAllocate(%[[C2_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 + +! CHECK: %[[TYPE_DESC_P1:.*]] = fir.address_of(@_QMpolyE.dt.p1) : !fir.ref>>>>) -> !fir.ref> +! CHECK: %[[TYPE_DESC_P1_CAST:.*]] = fir.convert %[[TYPE_DESC_P1]] : (!fir.ref>, !fir.ref, i32, i32) -> none +! CHECK: %[[C1:.*]] = arith.constant 1 : index +! CHECK: %[[C10:.*]] = arith.constant 10 : i32 +! CHECK: %[[C0:.*]] = arith.constant 0 : i32 +! CHECK: %[[C3_CAST:.*]] = fir.convert %[[C3]] : (!fir.ref>>>>) -> !fir.ref> +! CHECK: %[[C1_I64:.*]] = fir.convert %c1 : (index) -> i64 +! CHECK: %[[C10_I64:.*]] = fir.convert %[[C10]] : (i32) -> i64 +! CHECK: %{{.*}} = fir.call @_FortranAAllocatableSetBounds(%[[C3_CAST]], %[[C0]], %[[C1_I64]], %[[C10_I64]]) : (!fir.ref>, i32, i64, i64) -> none +! CHECK: %[[C3_CAST:.*]] = fir.convert %[[C3]] : (!fir.ref>>>>) -> !fir.ref> +! CHECK: %{{.*}} = fir.call @_FortranAAllocatableAllocate(%[[C3_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 + +! CHECK: %[[TYPE_DESC_P2:.*]] = fir.address_of(@_QMpolyE.dt.p2) : !fir.ref>>>>) -> !fir.ref> +! CHECK: %[[TYPE_DESC_P2_CAST:.*]] = fir.convert %[[TYPE_DESC_P2]] : (!fir.ref>, !fir.ref, i32, i32) -> none +! CHECK: %[[C1:.*]] = arith.constant 1 : index +! CHECK: %[[C20:.*]] = arith.constant 20 : i32 +! CHECK: %[[C0:.*]] = arith.constant 0 : i32 +! CHECK: %[[C4_CAST:.*]] = fir.convert %[[C4]] : (!fir.ref>>>>) -> !fir.ref> +! CHECK: %[[C1_I64:.*]] = fir.convert %[[C1]] : (index) -> i64 +! CHECK: %[[C20_I64:.*]] = fir.convert %[[C20]] : (i32) -> i64 +! CHECK: %{{.*}} = fir.call @_FortranAAllocatableSetBounds(%[[C4_CAST]], %[[C0]], %[[C1_I64]], %[[C20_I64]]) : (!fir.ref>, i32, i64, i64) -> none +! CHECK: %[[C4_CAST:.*]] = fir.convert %[[C4]] : (!fir.ref>>>>) -> !fir.ref> +! CHECK: %{{.*}} = fir.call @_FortranAAllocatableAllocate(%[[C4_CAST]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 + + +! Check code generation of allocate runtime calls for polymoprhic entities. This +! is done from Fortran so we don't have a file full of auto-generated type info +! in order to perform the checks. + +! LLVM-LABEL: define void @_QQmain() +! LLVM: %{{.*}} = call {} @_FortranAAllocatableInitDerived(ptr @_QFEp, ptr @_QMpolyE.dt.p1, i32 0, i32 0) +! LLVM: %{{.*}} = call i32 @_FortranAAllocatableAllocate(ptr @_QFEp, i1 false, ptr null, ptr @_QQcl.{{.*}}, i32 {{.*}}) +! LLVM: %{{.*}} = call {} @_FortranAAllocatableInitDerived(ptr @_QFEc1, ptr @_QMpolyE.dt.p1, i32 0, i32 0) +! LLVM: %{{.*}} = call i32 @_FortranAAllocatableAllocate(ptr @_QFEc1, i1 false, ptr null, ptr @_QQcl.{{.*}}, i32 {{.*}}) +! LLVM: %{{.*}} = call {} @_FortranAAllocatableInitDerived(ptr @_QFEc2, ptr @_QMpolyE.dt.p2, i32 0, i32 0) +! LLVM: %{{.*}} = call i32 @_FortranAAllocatableAllocate(ptr @_QFEc2, i1 false, ptr null, ptr @_QQcl.{{.*}}, i32 {{.*}}) +! LLVM: %{{.*}} = call {} @_FortranAAllocatableInitDerived(ptr @_QFEc3, ptr @_QMpolyE.dt.p1, i32 1, i32 0) +! LLVM: %{{.*}} = call {} @_FortranAAllocatableSetBounds(ptr @_QFEc3, i32 0, i64 1, i64 10) +! LLVM: %{{.*}} = call i32 @_FortranAAllocatableAllocate(ptr @_QFEc3, i1 false, ptr null, ptr @_QQcl.{{.*}}, i32 {{.*}}) +! LLVM: %{{.*}} = call {} @_FortranAAllocatableInitDerived(ptr @_QFEc4, ptr @_QMpolyE.dt.p2, i32 1, i32 0) +! LLVM: %{{.*}} = call {} @_FortranAAllocatableSetBounds(ptr @_QFEc4, i32 0, i64 1, i64 20) +! LLVM: %{{.*}} = call i32 @_FortranAAllocatableAllocate(ptr @_QFEc4, i1 false, ptr null, ptr @_QQcl.{{.*}}, i32 {{.*}})