From 5cc3879e111c696cf635d4278abbec39404b7aed Mon Sep 17 00:00:00 2001 From: Valentin Clement Date: Tue, 17 Jan 2023 16:11:45 +0100 Subject: [PATCH] [flang] Support allocate with source for polymorphic entities Apply the source type spec to the descriptor for polyrmophic entities. Reviewed By: PeteSteinfeld Differential Revision: https://reviews.llvm.org/D141822 --- flang/lib/Lower/Allocatable.cpp | 126 +++++++++++++++++---------- flang/test/Lower/allocatable-polymorphic.f90 | 35 ++++++++ 2 files changed, 116 insertions(+), 45 deletions(-) diff --git a/flang/lib/Lower/Allocatable.cpp b/flang/lib/Lower/Allocatable.cpp index 73c5027..2587544 100644 --- a/flang/lib/Lower/Allocatable.cpp +++ b/flang/lib/Lower/Allocatable.cpp @@ -558,13 +558,30 @@ private: genAllocateObjectInit(box); if (alloc.hasCoarraySpec()) TODO(loc, "coarray allocation"); - if (alloc.type.IsPolymorphic()) - TODO(loc, "polymorphic allocation with SOURCE specifier"); // Set length of the allocate object if it has. Otherwise, get the length // from source for the deferred length parameter. if (lenParams.empty() && box.isCharacter() && !box.hasNonDeferredLenParams()) lenParams.push_back(fir::factory::readCharLen(builder, loc, sourceExv)); + if (alloc.type.IsPolymorphic()) { + assert(sourceExpr->GetType() && "null type not expected"); + if (alloc.type.IsUnlimitedPolymorphic() && + sourceExpr->GetType()->IsUnlimitedPolymorphic()) + TODO(loc, "allocate unlimited polymorphic entity from unlimited " + "polymorphic source"); + + if (sourceExpr->GetType()->category() == TypeCategory::Derived) { + mlir::Type tdescType = + fir::TypeDescType::get(mlir::NoneType::get(builder.getContext())); + mlir::Value typeDescAddr = builder.create( + loc, tdescType, fir::getBase(sourceExv)); + genInitDerived(box, typeDescAddr, alloc.getSymbol().Rank()); + } else { + genInitIntrinsic(box, sourceExpr->GetType()->category(), + sourceExpr->GetType()->kind(), + alloc.getSymbol().Rank()); + } + } genSetDeferredLengthParameters(alloc, box); genAllocateObjectBounds(alloc, box); mlir::Value stat = @@ -582,6 +599,63 @@ private: errorManager.assignStat(builder, loc, stat); } + /// Generate call to PointerNullifyDerived or AllocatableInitDerived + /// to set the dynamic type information. + void genInitDerived(const fir::MutableBoxValue &box, mlir::Value typeDescAddr, + int rank, int corank = 0) { + mlir::func::FuncOp callee = + box.isPointer() + ? fir::runtime::getRuntimeFunc( + loc, builder) + : 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 rankValue = + builder.createIntegerConstant(loc, inputTypes[2], rank); + mlir::Value corankValue = + builder.createIntegerConstant(loc, inputTypes[3], corank); + args.push_back(rankValue); + args.push_back(corankValue); + builder.create(loc, callee, args); + } + + /// Generate call to PointerNullifyIntrinsic or AllocatableInitIntrinsic to + /// set the dynamic type information for a polymorphic entity from an + /// intrinsic type spec. + void genInitIntrinsic(const fir::MutableBoxValue &box, + const TypeCategory category, int64_t kind, int rank, + int corank = 0) { + mlir::func::FuncOp callee = + box.isPointer() + ? fir::runtime::getRuntimeFunc( + loc, builder) + : fir::runtime::getRuntimeFunc( + loc, builder); + + llvm::ArrayRef inputTypes = + callee.getFunctionType().getInputs(); + llvm::SmallVector args; + args.push_back(builder.createConvert(loc, inputTypes[0], box.getAddr())); + mlir::Value categoryValue = builder.createIntegerConstant( + loc, inputTypes[1], static_cast(category)); + mlir::Value kindValue = + builder.createIntegerConstant(loc, inputTypes[2], kind); + mlir::Value rankValue = + builder.createIntegerConstant(loc, inputTypes[3], rank); + mlir::Value corankValue = + builder.createIntegerConstant(loc, inputTypes[4], corank); + args.push_back(categoryValue); + args.push_back(kindValue); + args.push_back(rankValue); + args.push_back(corankValue); + builder.create(loc, callee, args); + } + /// 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, @@ -599,31 +673,10 @@ private: // unlimited polymorphic entity. if (typeSpec->AsIntrinsic() && fir::isUnlimitedPolymorphicType(fir::getBase(box).getType())) { - mlir::func::FuncOp callee = - box.isPointer() - ? fir::runtime::getRuntimeFunc( - loc, builder) - : fir::runtime::getRuntimeFunc( - loc, builder); - - llvm::ArrayRef inputTypes = - callee.getFunctionType().getInputs(); - llvm::SmallVector args; - args.push_back(builder.createConvert(loc, inputTypes[0], box.getAddr())); - mlir::Value category = builder.createIntegerConstant( - loc, inputTypes[1], - static_cast(typeSpec->AsIntrinsic()->category())); - mlir::Value kind = builder.createIntegerConstant( - loc, inputTypes[2], - Fortran::evaluate::ToInt64(typeSpec->AsIntrinsic()->kind()).value()); - mlir::Value rank = builder.createIntegerConstant( - loc, inputTypes[3], alloc.getSymbol().Rank()); - mlir::Value corank = builder.createIntegerConstant(loc, inputTypes[4], 0); - args.push_back(category); - args.push_back(kind); - args.push_back(rank); - args.push_back(corank); - builder.create(loc, callee, args); + genInitIntrinsic( + box, typeSpec->AsIntrinsic()->category(), + Fortran::evaluate::ToInt64(typeSpec->AsIntrinsic()->kind()).value(), + alloc.getSymbol().Rank()); return; } @@ -633,24 +686,7 @@ private: auto typeDescAddr = Fortran::lower::getTypeDescAddr( builder, loc, typeSpec->derivedTypeSpec()); - mlir::func::FuncOp callee = - box.isPointer() - ? fir::runtime::getRuntimeFunc( - loc, builder) - : 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 corank = builder.createIntegerConstant(loc, inputTypes[3], 0); - args.push_back(rank); - args.push_back(corank); - builder.create(loc, callee, args); + genInitDerived(box, typeDescAddr, alloc.getSymbol().Rank()); } /// Returns a pointer to the DeclTypeSpec if a type-spec is provided in the diff --git a/flang/test/Lower/allocatable-polymorphic.f90 b/flang/test/Lower/allocatable-polymorphic.f90 index bfaf3e8..d1f68f2 100644 --- a/flang/test/Lower/allocatable-polymorphic.f90 +++ b/flang/test/Lower/allocatable-polymorphic.f90 @@ -457,6 +457,41 @@ contains ! 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 + subroutine test_allocate_with_source() + type(p2) :: x(10) + class(p1), pointer :: p(:) + integer(4) :: i(20) + class(*), pointer :: up(:) + + allocate(p, source=x) + allocate(up, source=i) + end subroutine + +! CHECK-LABEL: func.func @_QMpolyPtest_allocate_with_source() { +! CHECK: %[[I:.*]] = fir.alloca !fir.array<20xi32> {bindc_name = "i", uniq_name = "_QMpolyFtest_allocate_with_sourceEi"} +! CHECK: %[[P:.*]] = fir.alloca !fir.class>>> {bindc_name = "p", uniq_name = "_QMpolyFtest_allocate_with_sourceEp"} +! 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: %[[TYPE_DESC_X:.*]] = fir.box_tdesc %[[EMBOX_X]] : (!fir.box>>) -> !fir.tdesc +! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[P]] : (!fir.ref>>>>) -> !fir.ref> +! CHECK: %[[TYPE_DESC_NONE:.*]] = fir.convert %[[TYPE_DESC_X]] : (!fir.tdesc) -> !fir.ref +! CHECK: %[[RANK:.*]] = arith.constant 1 : i32 +! CHECK: %[[CORANK:.*]] = arith.constant 0 : i32 +! CHECK: %{{.*}} = fir.call @_FortranAPointerNullifyDerived(%[[BOX_NONE]], %[[TYPE_DESC_NONE]], %[[RANK]], %[[CORANK]]) {{.*}} : (!fir.ref>, !fir.ref, i32, 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: %[[UP_BOX_NONE:.*]] = fir.convert %[[UP]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[CAT:.*]] = arith.constant 0 : i32 +! CHECK: %[[KIND:.*]] = arith.constant 4 : i32 +! CHECK: %[[RANK:.*]] = arith.constant 1 : i32 +! CHECK: %[[CORANK:.*]] = arith.constant 0 : i32 +! CHECK: %{{.*}} = fir.call @_FortranAPointerNullifyIntrinsic(%[[UP_BOX_NONE]], %[[CAT]], %[[KIND]], %[[RANK]], %[[CORANK]]) {{.*}} : (!fir.ref>, i32, i32, i32, i32) -> none + end module -- 2.7.4