[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/lib/Lower/Allocatable.cpp

if (alloc.hasCoarraySpec())
       TODO(loc, "coarray allocation");
     if (alloc.getShapeSpecs().size() > 0 && sourceExv.rank() == 0)
       TODO(loc, "allocate array object with scalar 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<fir::BoxTypeDescOp>(
-            loc, tdescType, fir::getBase(sourceExv));
-        genInitDerived(box, typeDescAddr, alloc.getSymbol().Rank());
-      } else {
-        genInitIntrinsic(box, sourceExpr->GetType()->category(),
-                         sourceExpr->GetType()->kind(),
-                         alloc.getSymbol().Rank());
-      }
-    }
+    if (alloc.type.IsPolymorphic())
+      genRuntimeAllocateApplyMold(builder, loc, box, sourceExv);
     genSetDeferredLengthParameters(alloc, box);
     genAllocateObjectBounds(alloc, box);
     mlir::Value stat =
         genRuntimeAllocateSource(builder, loc, box, sourceExv, errorManager);
     fir::factory::syncMutableBoxFromIRBox(builder, loc, box);
     errorManager.assignStat(builder, loc, stat);
   }
 

flang/test/Lower/allocatable-polymorphic.f90

subroutine test_allocate_with_source()
     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<!fir.ptr<!fir.array<?x!fir.type<_QMpolyTp1{a:i32,b:i32}>>>> {bindc_name = "p", uniq_name = "_QMpolyFtest_allocate_with_sourceEp"}
 ! CHECK: %[[UP:.*]] = fir.alloca !fir.class<!fir.ptr<!fir.array<?xnone>>> {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.array<10x!fir.type<_QMpolyTp2{a:i32,b:i32,c:i32}>>>, !fir.shape<1>) -> !fir.box<!fir.array<10x!fir.type<_QMpolyTp2{a:i32,b:i32,c:i32}>>>
-! CHECK: %[[TYPE_DESC_X:.*]] = fir.box_tdesc %[[EMBOX_X]] : (!fir.box<!fir.array<10x!fir.type<_QMpolyTp2{a:i32,b:i32,c:i32}>>>) -> !fir.tdesc<none>
-! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[P]] : (!fir.ref<!fir.class<!fir.ptr<!fir.array<?x!fir.type<_QMpolyTp1{a:i32,b:i32}>>>>>) -> !fir.ref<!fir.box<none>>
-! CHECK: %[[TYPE_DESC_NONE:.*]] = fir.convert %[[TYPE_DESC_X]] : (!fir.tdesc<none>) -> !fir.ref<none>
-! 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.box<none>>, !fir.ref<none>, i32, i32) -> none
+! CHECK: %[[P_BOX_NONE:.*]] = fir.convert %[[P]] : (!fir.ref<!fir.class<!fir.ptr<!fir.array<?x!fir.type<_QMpolyTp1{a:i32,b:i32}>>>>>) -> !fir.ref<!fir.box<none>>
+! CHECK: %[[X_BOX_NONE:.*]] = fir.convert %[[EMBOX_X]] : (!fir.box<!fir.array<10x!fir.type<_QMpolyTp2{a:i32,b:i32,c:i32}>>>) -> !fir.box<none>
+! CHECK: %{{.*}} = fir.call @_FortranAPointerApplyMold(%[[P_BOX_NONE]], %[[X_BOX_NONE]]) {{.*}} : (!fir.ref<!fir.box<none>>, !fir.box<none>) -> none
 ! CHECK: %{{.*}} = fir.call @_FortranAPointerSetBounds
 ! CHECK: %[[BOX_NONE_P:.*]] = fir.convert %[[P]] : (!fir.ref<!fir.class<!fir.ptr<!fir.array<?x!fir.type<_QMpolyTp1{a:i32,b:i32}>>>>>) -> !fir.ref<!fir.box<none>>
 ! CHECK: %[[BOX_NONE_X:.*]] = fir.convert %[[EMBOX_X]] : (!fir.box<!fir.array<10x!fir.type<_QMpolyTp2{a:i32,b:i32,c:i32}>>>) -> !fir.box<none>
 ! CHECK: %{{.*}} = fir.call @_FortranAPointerAllocateSource(%[[BOX_NONE_P]], %[[BOX_NONE_X]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref<!fir.box<none>>, !fir.box<none>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
-
+! CHECK: %[[EMBOX_I:.*]] = fir.embox %[[I]](%{{.*}}) : (!fir.ref<!fir.array<20xi32>>, !fir.shape<1>) -> !fir.box<!fir.array<20xi32>>
 ! 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
+! CHECK: %[[I_BOX_NONE:.*]] = fir.convert %[[EMBOX_I]] : (!fir.box<!fir.array<20xi32>>) -> !fir.box<none>
+! CHECK: %{{.*}} = fir.call @_FortranAPointerApplyMold(%[[UP_BOX_NONE]], %[[I_BOX_NONE]]) {{.*}} : (!fir.ref<!fir.box<none>>, !fir.box<none>) -> none
+! CHECK: %{{.*}} = fir.call @_FortranAPointerSetBounds
+! CHECK: %[[UP_BOX_NONE:.*]] = fir.convert %[[UP]] : (!fir.ref<!fir.class<!fir.ptr<!fir.array<?xnone>>>>) -> !fir.ref<!fir.box<none>>
+! CHECK: %[[I_BOX_NONE:.*]] = fir.convert %[[EMBOX_I]] : (!fir.box<!fir.array<20xi32>>) -> !fir.box<none>
+! CHECK: %{{.*}} = fir.call @_FortranAPointerAllocateSource(%[[UP_BOX_NONE]], %[[I_BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref<!fir.box<none>>, !fir.box<none>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
+
+  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: %{{.*}} = fir.call @_FortranAAllocatableApplyMold(%[[A_BOX_NONE]], %[[B_BOX_NONE]]) {{.*}} : (!fir.ref<!fir.box<none>>, !fir.box<none>) -> 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()

flang/unittests/Runtime/Pointer.cpp

TEST(Pointer, BasicAllocateDeallocate) {
   EXPECT_EQ(p->Elements(), 10u);
   EXPECT_EQ(p->GetDimension(0).LowerBound(), 2);
   EXPECT_EQ(p->GetDimension(0).UpperBound(), 11);
   // DEALLOCATE(p)
   RTNAME(PointerDeallocate)
   (*p, /*hasStat=*/false, /*errMsg=*/nullptr, __FILE__, __LINE__);
   EXPECT_FALSE(RTNAME(PointerIsAssociated)(*p));
 }
+
+TEST(Pointer, ApplyMoldAllocation) {
+  // REAL(4), POINTER :: p
+  auto m{Descriptor::Create(TypeCode{Fortran::common::TypeCategory::Real, 4}, 4,
+      nullptr, 0, nullptr, CFI_attribute_pointer)};
+  RTNAME(PointerAllocate)
+  (*m, /*hasStat=*/false, /*errMsg=*/nullptr, __FILE__, __LINE__);
+
+  // CLASS(*), POINTER :: p
+  auto p{Descriptor::Create(TypeCode{Fortran::common::TypeCategory::Real, 4}, 4,
+      nullptr, 0, nullptr, CFI_attribute_pointer)};
+  p->raw().elem_len = 0;
+  p->raw().type = CFI_type_other;
+
+  RTNAME(PointerApplyMold)(*p, *m);
+  RTNAME(PointerAllocate)
+  (*p, /*hasStat=*/false, /*errMsg=*/nullptr, __FILE__, __LINE__);
+
+  EXPECT_EQ(p->ElementBytes(), m->ElementBytes());
+  EXPECT_EQ(p->type(), m->type());
+}