[flang] Handle dynamic type in move_alloc

[clementval]

Summary

Update move_alloc to carry over the dyanmic type of from to to
and reset the dynamic type of from to its declared type when it
is polymorphic.

[PeteSteinfeld]

All builds and tests correctly and looks good to me.

Note that one of the buildbots failed to apply the patch. I didn't see anything wrong with the patch, though.

[clementval]

rebase

flang/include/flang/Runtime/allocatable.h

int RTNAME(AllocatableAllocateSource)(Descriptor &, const Descriptor &source,
     bool hasStat = false, const Descriptor *errMsg = nullptr,
     const char *sourceFile = nullptr, int sourceLine = 0);
 
 // Implements the intrinsic subroutine MOVE_ALLOC (16.9.137 in F'2018,
 // but note the order of first two arguments is reversed for consistency
 // with the other APIs for allocatables.)  The destination descriptor
 // must be initialized.
 std::int32_t RTNAME(MoveAlloc)(Descriptor &to, Descriptor &from,
-    bool hasStat = false, const Descriptor *errMsg = nullptr,
-    const char *sourceFile = nullptr, int sourceLine = 0);
+    const typeInfo::DerivedType *, bool hasStat = false,
+    const Descriptor *errMsg = nullptr, const char *sourceFile = nullptr,
+    int sourceLine = 0);
 
 // Deallocates an allocatable.  Finalizes elements &/or components as needed.
 // The allocatable is left in an initialized state suitable for reallocation
 // with the same bounds, cobounds, and length type parameters.
 int RTNAME(AllocatableDeallocate)(Descriptor &, bool hasStat = false,
     const Descriptor *errMsg = nullptr, const char *sourceFile = nullptr,
     int sourceLine = 0);
 

flang/lib/Optimizer/Builder/Runtime/Allocatable.cpp

mlir::Value fir::runtime::genMoveAlloc(fir::FirOpBuilder &builder,
                                        mlir::Location loc, mlir::Value to,
                                        mlir::Value from, mlir::Value hasStat,
                                        mlir::Value errMsg) {
   mlir::func::FuncOp func{
       fir::runtime::getRuntimeFunc<mkRTKey(MoveAlloc)>(loc, builder)};
   mlir::FunctionType fTy{func.getFunctionType()};
   mlir::Value sourceFile{fir::factory::locationToFilename(builder, loc)};
   mlir::Value sourceLine{
-      fir::factory::locationToLineNo(builder, loc, fTy.getInput(5))};
+      fir::factory::locationToLineNo(builder, loc, fTy.getInput(6))};
+  mlir::Value declaredTypeDesc;
+  if (fir::isPolymorphicType(from.getType())) {
+    fir::ClassType clTy =
+        fir::dyn_cast_ptrEleTy(from.getType()).dyn_cast<fir::ClassType>();
+    mlir::Type derivedType = fir::unwrapInnerType(clTy.getEleTy());
+    declaredTypeDesc =
+        builder.create<fir::TypeDescOp>(loc, mlir::TypeAttr::get(derivedType));
+  } else {
+    declaredTypeDesc = builder.createNullConstant(loc);
+  }
   llvm::SmallVector<mlir::Value> args{fir::runtime::createArguments(
-      builder, loc, fTy, to, from, hasStat, errMsg, sourceFile, sourceLine)};
+      builder, loc, fTy, to, from, declaredTypeDesc, hasStat, errMsg,
+      sourceFile, sourceLine)};
 
   return builder.create<fir::CallOp>(loc, func, args).getResult(0);
 }

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);
 }
 
-std::int32_t RTNAME(MoveAlloc)(Descriptor &to, Descriptor &from, bool hasStat,
+std::int32_t RTNAME(MoveAlloc)(Descriptor &to, Descriptor &from,
+    const typeInfo::DerivedType *derivedType, bool hasStat,
     const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
   Terminator terminator{sourceFile, sourceLine};
 
   // If to and from are the same allocatable they must not be allocated
   // and nothing should be done.
   if (from.raw().base_addr == to.raw().base_addr && from.IsAllocated()) {
     return ReturnError(
         terminator, StatMoveAllocSameAllocatable, errMsg, hasStat);
   }
 
   if (to.IsAllocated()) {
     int stat{to.Destroy(/*finalize=*/true)};
     if (stat != StatOk) {
       return ReturnError(terminator, stat, errMsg, hasStat);
     }
   }
 
   // If from isn't allocated, the standard defines that nothing should be done.
   if (from.IsAllocated()) {
     to = from;
     from.raw().base_addr = nullptr;
+
+    // Carry over the dynamic type.
+    if (auto *toAddendum{to.Addendum()}) {
+      if (const auto *fromAddendum{from.Addendum()}) {
+        if (const auto *derived{fromAddendum->derivedType()}) {
+          toAddendum->set_derivedType(derived);
+        }
       }
+    }
+
+    // Reset from dynamic type if needed.
+    if (auto *fromAddendum{from.Addendum()}) {
+      if (derivedType) {
+        fromAddendum->set_derivedType(derivedType);
+      }
+    }
+  }
+
   return StatOk;
 }
 
 void RTNAME(AllocatableSetBounds)(Descriptor &descriptor, int zeroBasedDim,
     SubscriptValue lower, SubscriptValue upper) {
   INTERNAL_CHECK(zeroBasedDim >= 0 && zeroBasedDim < descriptor.rank());
   descriptor.GetDimension(zeroBasedDim).SetBounds(lower, upper);
   // The byte strides are computed when the object is allocated.

flang/test/Lower/Intrinsics/move_alloc.f90

   ! RUN: bbc -emit-fir %s -o - | FileCheck  %s
   ! RUN: flang-new -fc1 -emit-fir %s -o - | FileCheck %s
 
 ! CHECK-LABEL: to_from_only
 subroutine to_from_only
   ! CHECK: %[[a1:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?xi32>>>
   ! CHECK: %[[b1:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?xi32>>>
   integer, allocatable :: from(:), to(:)
   allocate(from(20))
   ! CHECK: %[[errMsg:.*]] = fir.absent !fir.box<none>
   ! CHECK: %[[false:.*]] = arith.constant false
   ! CHECK-DAG: %[[a2:.*]] = fir.convert %[[a1]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>) -> !fir.ref<!fir.box<none>>
   ! CHECK-DAG: %[[b2:.*]] = fir.convert %[[b1]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>) -> !fir.ref<!fir.box<none>>
   call move_alloc(from, to)
-  ! CHECK: fir.call @_FortranAMoveAlloc(%[[b2]], %[[a2]], %[[false]], %[[errMsg]], %{{.*}}, %{{.*}}) fastmath<contract> : (!fir.ref<!fir.box<none>>, !fir.ref<!fir.box<none>>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
+  ! CHECK: fir.call @_FortranAMoveAlloc(%[[b2]], %[[a2]], %{{.*}}, %[[false]], %[[errMsg]], %{{.*}}, %{{.*}}) fastmath<contract> : (!fir.ref<!fir.box<none>>, !fir.ref<!fir.box<none>>, !fir.ref<none>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
   ! CHECK-DAG:  %[[a3:.*]] = fir.load %[[a1:.*]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>
   ! CHECK-DAG:  %[[a4:.*]] = fir.box_addr %[[a3]] : (!fir.box<!fir.heap<!fir.array<?xi32>>>) -> !fir.heap<!fir.array<?xi32>>
   ! CHECK-DAG:  %[[b3:.*]] = fir.load %[[b1]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>
   ! CHECK-DAG:  %[[b4:.*]] = fir.box_addr %[[b3:.*]] : (!fir.box<!fir.heap<!fir.array<?xi32>>>) -> !fir.heap<!fir.array<?xi32>>
 end subroutine to_from_only
 
 ! CHECK-LABEL: to_from_stat
 subroutine to_from_stat
   ! CHECK-DAG: %[[a1:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?xi32>>>
   ! CHECK-DAG: %[[b1:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?xi32>>>
   integer, allocatable :: from(:), to(:)
   ! CHECK-DAG: %[[stat1:.*]] = fir.alloca i32
   integer :: stat
   allocate(from(20))
   ! CHECK: %[[errMsg:.*]] = fir.absent !fir.box<none>
   ! CHECK: %[[true:.*]] = arith.constant true
   ! CHECK-DAG: %[[a2:.*]] = fir.convert %[[a1]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>) -> !fir.ref<!fir.box<none>>
   ! CHECK-DAG: %[[b2:.*]] = fir.convert %[[b1]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>) -> !fir.ref<!fir.box<none>>
   call move_alloc(from, to, stat)
-  ! CHECK: %[[stat:.*]] = fir.call @_FortranAMoveAlloc(%[[b2]], %[[a2]], %[[true]], %[[errMsg]], %{{.*}}, %{{.*}}) fastmath<contract> : (!fir.ref<!fir.box<none>>, !fir.ref<!fir.box<none>>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
+  ! CHECK: %[[stat:.*]] = fir.call @_FortranAMoveAlloc(%[[b2]], %[[a2]], %{{.*}}, %[[true]], %[[errMsg]], %{{.*}}, %{{.*}}) fastmath<contract> : (!fir.ref<!fir.box<none>>, !fir.ref<!fir.box<none>>, !fir.ref<none>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
   ! CHECK-DAG:  %[[a3:.*]] = fir.load %[[a1:.*]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>
   ! CHECK-DAG:  %[[a4:.*]] = fir.box_addr %[[a3]] : (!fir.box<!fir.heap<!fir.array<?xi32>>>) -> !fir.heap<!fir.array<?xi32>>
   ! CHECK-DAG:  %[[b3:.*]] = fir.load %[[b1]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>
   ! CHECK-DAG:  %[[b4:.*]] = fir.box_addr %[[b3:.*]] : (!fir.box<!fir.heap<!fir.array<?xi32>>>) -> !fir.heap<!fir.array<?xi32>>
 end subroutine to_from_stat
 
 ! CHECK-LABEL: to_from_stat_errmsg
 subroutine to_from_stat_errmsg
   ! CHECK-DAG: %[[errMsg1:.*]] = fir.alloca !fir.char<1,64>
   ! CHECK-DAG: %[[a1:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?xi32>>>
   ! CHECK-DAG: %[[b1:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?xi32>>>
   integer, allocatable :: from(:), to(:)
   ! CHECK-DAG: %[[stat1:.*]] = fir.alloca i32
   integer :: stat
   character :: errMsg*64
   allocate(from(20))
   ! CHECK: %[[errMsg2:.*]] = fir.embox %[[errMsg1]] : (!fir.ref<!fir.char<1,64>>) -> !fir.box<!fir.char<1,64>>
   ! CHECK: %[[true:.*]] = arith.constant true
   ! CHECK-DAG: %[[errMsg3:.*]] = fir.convert %[[errMsg2]] : (!fir.box<!fir.char<1,64>>) -> !fir.box<none>
   ! CHECK-DAG: %[[a2:.*]] = fir.convert %[[a1]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>) -> !fir.ref<!fir.box<none>>
   ! CHECK-DAG: %[[b2:.*]] = fir.convert %[[b1]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>) -> !fir.ref<!fir.box<none>>
   call move_alloc(from, to, stat, errMsg)
-  ! CHECK: %[[stat:.*]] = fir.call @_FortranAMoveAlloc(%[[b2]], %[[a2]], %[[true]], %[[errMsg3]], %{{.*}}, %{{.*}}) fastmath<contract> : (!fir.ref<!fir.box<none>>, !fir.ref<!fir.box<none>>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
+  ! CHECK: %[[stat:.*]] = fir.call @_FortranAMoveAlloc(%[[b2]], %[[a2]], %{{.*}}, %[[true]], %[[errMsg3]], %{{.*}}, %{{.*}}) fastmath<contract> : (!fir.ref<!fir.box<none>>, !fir.ref<!fir.box<none>>, !fir.ref<none>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
   ! CHECK-DAG:  %[[a3:.*]] = fir.load %[[a1:.*]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>
   ! CHECK-DAG:  %[[a4:.*]] = fir.box_addr %[[a3]] : (!fir.box<!fir.heap<!fir.array<?xi32>>>) -> !fir.heap<!fir.array<?xi32>>
   ! CHECK-DAG:  %[[b3:.*]] = fir.load %[[b1]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>
   ! CHECK-DAG:  %[[b4:.*]] = fir.box_addr %[[b3:.*]] : (!fir.box<!fir.heap<!fir.array<?xi32>>>) -> !fir.heap<!fir.array<?xi32>>
 end subroutine to_from_stat_errmsg

flang/test/Lower/polymorphic.f90

 ! CHECK-LABEL: func.func @_QMpolymorphic_testPtest_char_to_up_pointer(
 ! CHECK-SAME: %[[C:.*]]: !fir.boxchar<1> {fir.bindc_name = "c", fir.target}) {
 ! CHECK: %[[NEW_BOX:.*]] = fir.alloca !fir.class<!fir.ptr<none>>
 ! CHECK: %[[UNBOXCHAR:.*]]:2 = fir.unboxchar %arg0 : (!fir.boxchar<1>) -> (!fir.ref<!fir.char<1,?>>, index)
 ! CHECK: %[[EMBOX:.*]] = fir.embox %[[UNBOXCHAR]]#0 typeparams %[[UNBOXCHAR]]#1 : (!fir.ref<!fir.char<1,?>>, index) -> !fir.class<!fir.ptr<none>>
 ! CHECK: fir.store %[[EMBOX]] to %[[NEW_BOX]] : !fir.ref<!fir.class<!fir.ptr<none>>>
 ! CHECK: fir.call @_QMpolymorphic_testPup_pointer(%[[NEW_BOX]]) {{.*}} : (!fir.ref<!fir.class<!fir.ptr<none>>>) -> ()
 
+  subroutine move_alloc_poly(a, b)
+    class(p1), allocatable :: a, b
+
+    call move_alloc(a, b)
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMpolymorphic_testPmove_alloc_poly(
+! CHECK-SAME: %[[A:.*]]: !fir.ref<!fir.class<!fir.heap<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>> {fir.bindc_name = "a"}, %[[B:.*]]: !fir.ref<!fir.class<!fir.heap<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>> {fir.bindc_name = "b"}) {
+! CHECK: %[[TYPE_DESC:.*]] = fir.type_desc !fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>
+! CHECK: %[[B_CONV:.*]] = fir.convert %[[B]] : (!fir.ref<!fir.class<!fir.heap<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>>) -> !fir.ref<!fir.box<none>>
+! CHECK: %[[A_CONV:.*]] = fir.convert %[[A]] : (!fir.ref<!fir.class<!fir.heap<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>>) -> !fir.ref<!fir.box<none>>
+! CHECK: %[[TYPE_DESC_CONV:.*]] = fir.convert %[[TYPE_DESC]] : (!fir.tdesc<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>) -> !fir.ref<none>
+! CHECK: %{{.*}} = fir.call @_FortranAMoveAlloc(%[[B_CONV]], %[[A_CONV]], %[[TYPE_DESC_CONV]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref<!fir.box<none>>, !fir.ref<!fir.box<none>>, !fir.ref<none>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
+
 end module
 
 program test
   use polymorphic_test
   type(outer), allocatable :: o
   integer :: i(5)
   logical :: l(5)
   allocate(o)

flang/unittests/Optimizer/Builder/Runtime/AllocatableTest.cpp

TEST_F(RuntimeCallTest, genMoveAlloc) {
   mlir::Location loc = firBuilder->getUnknownLoc();
   mlir::Type seqTy =
       fir::SequenceType::get(fir::SequenceType::Shape(1, 10), i32Ty);
   mlir::Value from = firBuilder->create<fir::UndefOp>(loc, seqTy);
   mlir::Value to = firBuilder->create<fir::UndefOp>(loc, seqTy);
   mlir::Value errMsg = firBuilder->create<fir::UndefOp>(loc, seqTy);
   mlir::Value hasStat = firBuilder->createBool(loc, false);
   fir::runtime::genMoveAlloc(*firBuilder, loc, to, from, hasStat, errMsg);
-  checkCallOpFromResultBox(to, "_FortranAMoveAlloc", 4);
+  checkCallOpFromResultBox(to, "_FortranAMoveAlloc", 5);
 }

flang/unittests/Runtime/Allocatable.cpp

TEST(AllocatableTest, MoveAlloc) {
   // ALLOCATE(a(20))
   a->GetDimension(0).SetBounds(1, 20);
   a->Allocate();
 
   EXPECT_TRUE(a->IsAllocated());
   EXPECT_FALSE(b->IsAllocated());
 
   // Simple move_alloc
-  RTNAME(MoveAlloc)(*b, *a, false, nullptr, __FILE__, __LINE__);
+  RTNAME(MoveAlloc)(*b, *a, nullptr, false, nullptr, __FILE__, __LINE__);
   EXPECT_FALSE(a->IsAllocated());
   EXPECT_TRUE(b->IsAllocated());
 
   // move_alloc with stat
   std::int32_t stat{
-      RTNAME(MoveAlloc)(*a, *b, true, nullptr, __FILE__, __LINE__)};
+      RTNAME(MoveAlloc)(*a, *b, nullptr, true, nullptr, __FILE__, __LINE__)};
   EXPECT_TRUE(a->IsAllocated());
   EXPECT_FALSE(b->IsAllocated());
   EXPECT_EQ(stat, 0);
 
   // move_alloc with errMsg
   auto errMsg{Descriptor::Create(
       sizeof(char), 64, nullptr, 0, nullptr, CFI_attribute_allocatable)};
   errMsg->Allocate();
-  RTNAME(MoveAlloc)(*b, *a, false, errMsg.get(), __FILE__, __LINE__);
+  RTNAME(MoveAlloc)(*b, *a, nullptr, false, errMsg.get(), __FILE__, __LINE__);
   EXPECT_FALSE(a->IsAllocated());
   EXPECT_TRUE(b->IsAllocated());
 
   // move_alloc with stat and errMsg
-  stat = RTNAME(MoveAlloc)(*a, *b, true, errMsg.get(), __FILE__, __LINE__);
+  stat = RTNAME(MoveAlloc)(
+      *a, *b, nullptr, true, errMsg.get(), __FILE__, __LINE__);
   EXPECT_TRUE(a->IsAllocated());
   EXPECT_FALSE(b->IsAllocated());
   EXPECT_EQ(stat, 0);
 
   // move_alloc with the same deallocated array
-  stat = RTNAME(MoveAlloc)(*b, *b, true, errMsg.get(), __FILE__, __LINE__);
+  stat = RTNAME(MoveAlloc)(
+      *b, *b, nullptr, true, errMsg.get(), __FILE__, __LINE__);
   EXPECT_FALSE(b->IsAllocated());
   EXPECT_EQ(stat, 0);
 
   // move_alloc with the same allocated array should fail
-  stat = RTNAME(MoveAlloc)(*a, *a, true, errMsg.get(), __FILE__, __LINE__);
+  stat = RTNAME(MoveAlloc)(
+      *a, *a, nullptr, true, errMsg.get(), __FILE__, __LINE__);
   EXPECT_EQ(stat, 109);
   std::string_view errStr{errMsg->OffsetElement(), errMsg->ElementBytes()};
   auto trim_pos = errStr.find_last_not_of(' ');
   if (trim_pos != errStr.npos)
     errStr.remove_suffix(errStr.size() - trim_pos - 1);
   EXPECT_EQ(errStr, "MOVE_ALLOC passed the same address as to and from");
 }