[flang] Allocate polymorphic with SOURCE= using ApplyMold

[clementval]

Summary

Source allocation is similar to mold allocation + assignment. Use
ApplyMold runtime entry point for polymorphic source allocation.
It could be generalized for other source allocation.

[clementval]

This is not working as expected. An custom runtime entry point will be added.

[clementval]

Use custom entry point

[clementval]

Fix function name length

[jeanPerier]

LGTM, out of curiosity what went wrong when using the MOLD runtime entry point (I would also have expected the MOLD and SOURCE case to be similar expect for the extra assignment part in SOURCE)?

[PeteSteinfeld]

All builds and tests correctly and looks good.

But it would be even better if you would add a test to .../llvm-project/flang/unittests/Runtime.

[clementval]

In D141996#4061946, @jeanPerier wrote:

LGTM, out of curiosity what went wrong when using the MOLD runtime entry point (I would also have expected the MOLD and SOURCE case to be similar expect for the extra assignment part in SOURCE)?

In fact ApplyMold seems to do the trick just fine and would be needed as well for TypeCategory::Character. I'll will update the patch to use ApplyMold so the runtime has less entry point.

[clementval]

• Switch to ApplyMold for polymorphic source allocation
• Add unittest

[clementval]

@jeanPerier @PeteSteinfeld Since the new update is quite different, can you have a second look?

[PeteSteinfeld]

Thanks, @clementval. All still looks good.

[jeanPerier]

In D141996#4062668, @clementval wrote:

@jeanPerier @PeteSteinfeld Since the new update is quite different, can you have a second look?

Looks good, thanks for this simplification!

flang/include/flang/Runtime/allocatable.h

 // but needs reinitialization in a deallocated state only when there is
 // a change of type, rank, or corank.
 void RTNAME(AllocatableInitIntrinsic)(
     Descriptor &, TypeCategory, int kind, int rank = 0, int corank = 0);
 void RTNAME(AllocatableInitCharacter)(Descriptor &, SubscriptValue length = 0,
     int kind = 1, int rank = 0, int corank = 0);
 void RTNAME(AllocatableInitDerived)(
     Descriptor &, const typeInfo::DerivedType &, int rank = 0, int corank = 0);
+void RTNAME(AllocatableInitFromUnlimitedPolymorphicSource)(
+    Descriptor &, const Descriptor &, int rank = 0, int corank = 0);
 
 // Checks that an allocatable is not already allocated in statements
 // with STAT=.  Use this on a value descriptor before setting bounds or
 // type parameters.  Not necessary on a freshly initialized descriptor.
 // (If there's no STAT=, the error will be caught later anyway, but
 // this API allows the error to be caught before descriptor is modified.)
 // Return 0 on success (deallocated state), else the STAT= value.
 int RTNAME(AllocatableCheckAllocated)(Descriptor &,

flang/include/flang/Runtime/pointer.h

 
 // Initializes a pointer to a disassociated state for NULLIFY() or "p=>NULL()".
 void RTNAME(PointerNullifyIntrinsic)(
     Descriptor &, TypeCategory, int kind, int rank = 0, int corank = 0);
 void RTNAME(PointerNullifyCharacter)(Descriptor &, SubscriptValue length = 0,
     int kind = 1, int rank = 0, int corank = 0);
 void RTNAME(PointerNullifyDerived)(
     Descriptor &, const typeInfo::DerivedType &, int rank = 0, int corank = 0);
+void RTNAME(PointerNullifyFromUnlimitedPolymorphicSource)(
+    Descriptor &, const Descriptor &, int rank = 0, int corank = 0);
 
 // Explicitly sets the bounds of an initialized disassociated pointer.
 // The upper cobound is ignored for the last codimension.
 void RTNAME(PointerSetBounds)(
     Descriptor &, int zeroBasedDim, SubscriptValue lower, SubscriptValue upper);
 void RTNAME(PointerSetCoBounds)(Descriptor &, int zeroBasedCoDim,
     SubscriptValue lower, SubscriptValue upper = 0);
 

flang/lib/Lower/Allocatable.cpp

void genSourceAllocation(const Allocation &alloc,
     // 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) {
+          sourceExpr->GetType()->IsUnlimitedPolymorphic()) {
+        genInitFromUnlimitedPolymorphic(box, sourceExv,
+                                        alloc.getSymbol().Rank());
+      } else if (sourceExpr->GetType()->category() == TypeCategory::Derived) {
         mlir::Type tdescType =
             fir::TypeDescType::get(mlir::NoneType::get(builder.getContext()));
         mlir::Value typeDescAddr = builder.create<fir::BoxTypeDescOp>(
             loc, tdescType, fir::getBase(sourceExv));
         genInitDerived(box, typeDescAddr, alloc.getSymbol().Rank());
       } else {
         genInitIntrinsic(box, sourceExpr->GetType()->category(),
                          sourceExpr->GetType()->kind(),
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<fir::CallOp>(loc, callee, args);
   }
 
+  /// Generate call to PointerNullifyFromUnlimitedPolymorphicSource or
+  /// AllocatableInitFromUnlimitedPolymorphicSource to set the dynamic type
+  /// information for an unlimited polymorphic entity from an unlimited
+  /// polymorphic source.
+  void genInitFromUnlimitedPolymorphic(const fir::MutableBoxValue &box,
+                                       fir::ExtendedValue source, int rank,
+                                       int corank = 0) {
+    mlir::func::FuncOp callee =
+        box.isPointer()
+            ? fir::runtime::getRuntimeFunc<mkRTKey(
+                  PointerNullifyFromUnlimitedPolymorphicSource)>(loc, builder)
+            : fir::runtime::getRuntimeFunc<mkRTKey(
+                  AllocatableInitFromUnlimitedPolymorphicSource)>(loc, builder);
+    llvm::ArrayRef<mlir::Type> inputTypes =
+        callee.getFunctionType().getInputs();
+    llvm::SmallVector<mlir::Value> args;
+    args.push_back(builder.createConvert(loc, inputTypes[0], box.getAddr()));
+    args.push_back(
+        builder.createConvert(loc, inputTypes[1], fir::getBase(source)));
+    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<fir::CallOp>(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,
                   mlir::Location loc) {
     const Fortran::semantics::DeclTypeSpec *typeSpec =
         getIfAllocateStmtTypeSpec();
 
     // No type spec provided in allocate statement so the declared type spec is

flang/runtime/allocatable.cpp

 
 void RTNAME(AllocatableInitDerived)(Descriptor &descriptor,
     const typeInfo::DerivedType &derivedType, int rank, int corank) {
   INTERNAL_CHECK(corank == 0);
   descriptor.Establish(
       derivedType, nullptr, rank, nullptr, CFI_attribute_allocatable);
 }
 
+void RTNAME(AllocatableInitFromUnlimitedPolymorphicSource)(
+    Descriptor &descriptor, const Descriptor &source, int rank, int corank) {
+  if (source.type().IsDerived()) {
+    const DescriptorAddendum *addendum{source.Addendum()};
+    INTERNAL_CHECK(addendum != nullptr);
+    RTNAME(AllocatableInitDerived)
+    (descriptor, *addendum->derivedType(), rank, corank);
+  } else {
+    std::optional<std::pair<TypeCategory, int>> typeCode{
+        source.type().GetCategoryAndKind()};
+    INTERNAL_CHECK(typeCode);
+    RTNAME(AllocatableInitIntrinsic)
+    (descriptor, typeCode->first, typeCode->second, rank, corank);
+  }
+}
+
 int RTNAME(MoveAlloc)(Descriptor &to, const Descriptor & /*from*/,
     bool /*hasStat*/, const Descriptor * /*errMsg*/,
     const char * /*sourceFile*/, int /*sourceLine*/) {
   INTERNAL_CHECK(false); // TODO: MoveAlloc is not yet implemented
   return StatOk;
 }
 
 void RTNAME(AllocatableSetBounds)(Descriptor &descriptor, int zeroBasedDim,

flang/runtime/pointer.cpp

 }
 
 void RTNAME(PointerNullifyDerived)(Descriptor &pointer,
     const typeInfo::DerivedType &derivedType, int rank, int corank) {
   INTERNAL_CHECK(corank == 0);
   pointer.Establish(derivedType, nullptr, rank, nullptr, CFI_attribute_pointer);
 }
 
+void RTNAME(PointerNullifyFromUnlimitedPolymorphicSource)(
+    Descriptor &descriptor, const Descriptor &source, int rank, int corank) {
+  if (source.type().IsDerived()) {
+    const DescriptorAddendum *addendum{source.Addendum()};
+    INTERNAL_CHECK(addendum != nullptr);
+    RTNAME(PointerNullifyDerived)
+    (descriptor, *addendum->derivedType(), rank, corank);
+  } else {
+    std::optional<std::pair<TypeCategory, int>> typeCode{
+        source.type().GetCategoryAndKind()};
+    INTERNAL_CHECK(typeCode);
+    RTNAME(PointerNullifyIntrinsic)
+    (descriptor, typeCode->first, typeCode->second, rank, corank);
+  }
+}
+
 void RTNAME(PointerSetBounds)(Descriptor &pointer, int zeroBasedDim,
     SubscriptValue lower, SubscriptValue upper) {
   INTERNAL_CHECK(zeroBasedDim >= 0 && zeroBasedDim < pointer.rank());
   pointer.GetDimension(zeroBasedDim).SetBounds(lower, upper);
   // The byte strides are computed when the pointer is allocated.
 }
 
 // TODO: PointerSetCoBounds

flang/test/Lower/allocatable-polymorphic.f90

 
 ! CHECK: %[[UP_BOX_NONE:.*]] = fir.convert %[[UP]] : (!fir.ref<!fir.class<!fir.ptr<!fir.array<?xnone>>>>) -> !fir.ref<!fir.box<none>>
 ! 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<!fir.box<none>>, i32, i32, i32, i32) -> none
 
+  subroutine test_allocatable_up_from_up_mold(a, b)
+    class(*), allocatable :: a
+    class(*), pointer :: b
+    allocate(a, source = b)
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMpolyPtest_allocatable_up_from_up_mold(
+! CHECK-SAME: %[[A:.*]]: !fir.ref<!fir.class<!fir.heap<none>>> {fir.bindc_name = "a"}, %[[B:.*]]: !fir.ref<!fir.class<!fir.ptr<none>>> {fir.bindc_name = "b"}) {
+! CHECK: %[[LOAD_B:.*]] = fir.load %[[B]] : !fir.ref<!fir.class<!fir.ptr<none>>>
+! CHECK: %[[A_BOX_NONE:.*]] = fir.convert %[[A]] : (!fir.ref<!fir.class<!fir.heap<none>>>) -> !fir.ref<!fir.box<none>>
+! CHECK: %[[B_BOX_NONE:.*]] = fir.convert %[[LOAD_B]] : (!fir.class<!fir.ptr<none>>) -> !fir.box<none>
+! CHECK: %[[RANK:.*]] = arith.constant 0 : i32 
+! CHECK: %[[CORANK:.*]] = arith.constant 0 : i32 
+! CHECK: %{{.*}} = fir.call @_FortranAAllocatableInitFromUnlimitedPolymorphicSo(%[[A_BOX_NONE]], %[[B_BOX_NONE]], %[[RANK]], %[[CORANK]]) fastmath<contract> : (!fir.ref<!fir.box<none>>, !fir.box<none>, i32, i32) -> none 
+! CHECK: %[[A_BOX_NONE:.*]] = fir.convert %[[A]] : (!fir.ref<!fir.class<!fir.heap<none>>>) -> !fir.ref<!fir.box<none>>
+! CHECK: %[[B_BOX_NONE:.*]] = fir.convert %[[LOAD_B]] : (!fir.class<!fir.ptr<none>>) -> !fir.box<none>
+! CHECK: %{{.*}} = fir.call @_FortranAAllocatableAllocateSource(%[[A_BOX_NONE]], %[[B_BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref<!fir.box<none>>, !fir.box<none>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
+
 end module
 
 
 program test_alloc
   use poly
 
   call test_allocatable()
   call test_pointer()