[flang] Carry over dynamic type information when creating an unlimited polymorphic temp

[clementval]

Summary

The dyanmic type must be carried over in a PolymorphicValue when the address is
loaded from an unlimited polymorphic allocatable.

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/lib/Lower/ConvertExpr.cpp

static fir::ExtendedValue genLoad(fir::FirOpBuilder &builder,
                                   mlir::Location loc,
                                   const fir::ExtendedValue &addr) {
   return addr.match(
       [](const fir::CharBoxValue &box) -> fir::ExtendedValue { return box; },
       [&](const fir::PolymorphicValue &p) -> fir::ExtendedValue {
         if (fir::unwrapRefType(fir::getBase(p).getType())
                 .isa<fir::RecordType>())
           return p;
-        return builder.create<fir::LoadOp>(loc, fir::getBase(p));
+        mlir::Value load = builder.create<fir::LoadOp>(loc, fir::getBase(p));
+        return fir::PolymorphicValue(load, p.getSourceBox());
       },
       [&](const fir::UnboxedValue &v) -> fir::ExtendedValue {
         if (fir::unwrapRefType(fir::getBase(v).getType())
                 .isa<fir::RecordType>())
           return v;
         return builder.create<fir::LoadOp>(loc, fir::getBase(v));
       },
       [&](const fir::MutableBoxValue &box) -> fir::ExtendedValue {
         return genLoad(builder, loc,
                        fir::factory::genMutableBoxRead(builder, loc, box));
       },
       [&](const fir::BoxValue &box) -> fir::ExtendedValue {
-        if (box.isUnlimitedPolymorphic())
-          fir::emitFatalError(
-              loc, "attempting to load an unlimited polymorphic entity");
         return genLoad(builder, loc,
                        fir::factory::readBoxValue(builder, loc, box));
       },
       [&](const auto &) -> fir::ExtendedValue {
         fir::emitFatalError(
             loc, "attempting to load whole array or procedure address");
       });
 }

flang/lib/Optimizer/Builder/FIRBuilder.cpp

return box.match(
         return fir::factory::getExtents(loc, builder, load);
       },
       [&](const auto &) -> llvm::SmallVector<mlir::Value> { return {}; });
 }
 
 fir::ExtendedValue fir::factory::readBoxValue(fir::FirOpBuilder &builder,
                                               mlir::Location loc,
                                               const fir::BoxValue &box) {
-  assert(!box.isUnlimitedPolymorphic() && !box.hasAssumedRank() &&
+  assert(!box.hasAssumedRank() &&
          "cannot read unlimited polymorphic or assumed rank fir.box");
   auto addr =
       builder.create<fir::BoxAddrOp>(loc, box.getMemTy(), box.getAddr());
   if (box.isCharacter()) {
     auto len = fir::factory::readCharLen(builder, loc, box);
     if (box.rank() == 0)
       return fir::CharBoxValue(addr, len);
     return fir::CharArrayBoxValue(addr, len,
                                   fir::factory::readExtents(builder, loc, box),
                                   box.getLBounds());
   }
   if (box.isDerivedWithLenParameters())
     TODO(loc, "read fir.box with length parameters");
+  mlir::Value sourceBox;
+  if (box.isPolymorphic())
+    sourceBox = box.getAddr();
+  if (box.isPolymorphic() && box.rank() == 0)
+    return fir::PolymorphicValue(addr, sourceBox);
   if (box.rank() == 0)
     return addr;
   return fir::ArrayBoxValue(addr, fir::factory::readExtents(builder, loc, box),
-                            box.getLBounds());
+                            box.getLBounds(), sourceBox);
 }
 
 llvm::SmallVector<mlir::Value>
 fir::factory::getNonDefaultLowerBounds(fir::FirOpBuilder &builder,
                                        mlir::Location loc,
                                        const fir::ExtendedValue &exv) {
   return exv.match(
       [&](const fir::ArrayBoxValue &array) -> llvm::SmallVector<mlir::Value> {

flang/test/Lower/polymorphic.f90

type non_extensible
     sequence
     integer :: d
   end type
 
   type :: p4
     class(p1), allocatable :: a(:)
   end type
 
+  type :: p5
+    class(*), allocatable :: up
+  end type
+
   contains
 
   elemental subroutine assign_p1_int(lhs, rhs)
     class(p1), intent(inout) :: lhs
     integer, intent(in) :: rhs
     lhs%a = rhs
     lhs%b = rhs
   End Subroutine

 ! CHECK-LABEL: func.func @_QMpolymorphic_testPclass_array_with_entry(
 ! CHECK-SAME: %[[A:.*]]: !fir.class<!fir.array<?x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>> {fir.bindc_name = "a"}) {
 ! CHECK: %[[B:.*]] = fir.alloca !fir.class<!fir.heap<!fir.array<?x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>>
 
 ! CHECK-LABEL: func.func @_QMpolymorphic_testPg(
 ! CHECK-SAME: %[[B:.*]]: !fir.class<!fir.array<?x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>> {fir.bindc_name = "b"}) {
 ! CHECK: %[[A:.*]] = fir.alloca !fir.class<!fir.heap<!fir.array<?x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>>
 
+  subroutine pass_up(up)
+    class(*), intent(in) :: up
+  end subroutine
+
+  subroutine parenthesized_up(a)
+    type(p5) :: a
+    call pass_up((a%up))
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMpolymorphic_testPparenthesized_up(
+! CHECK-SAME: %[[ARG0:.*]]: !fir.ref<!fir.type<_QMpolymorphic_testTp5{up:!fir.class<!fir.heap<none>>}>> {fir.bindc_name = "a"}) {
+! CHECK: %[[ALLOCA:.*]] = fir.alloca
+! CHECK: %[[FIELD_UP:.*]] = fir.field_index up, !fir.type<_QMpolymorphic_testTp5{up:!fir.class<!fir.heap<none>>}>
+! CHECK: %[[COORD:.*]] = fir.coordinate_of %[[ARG0]], %[[FIELD_UP]] : (!fir.ref<!fir.type<_QMpolymorphic_testTp5{up:!fir.class<!fir.heap<none>>}>>, !fir.field) -> !fir.ref<!fir.class<!fir.heap<none>>>
+! CHECK: %[[LOAD:.*]] = fir.load %[[COORD]] : !fir.ref<!fir.class<!fir.heap<none>>>
+! CHECK: %[[BOX_ADDR:.*]] = fir.box_addr %[[LOAD]] : (!fir.class<!fir.heap<none>>) -> !fir.heap<none>
+! CHECK: %[[LOAD_ADDR:.*]] = fir.load %[[BOX_ADDR]] : !fir.heap<none>
+! CHECK: %[[NO_REASSOC:.*]] = fir.no_reassoc %[[LOAD_ADDR]] : none
+! CHECK: fir.store %[[NO_REASSOC]] to %[[ALLOCA]] : !fir.ref<none>
+! CHECK: %[[EMBOX:.*]] = fir.embox %[[ALLOCA]] source_box %[[LOAD]] : (!fir.ref<none>, !fir.class<!fir.heap<none>>) -> !fir.class<none>
+! CHECK: fir.call @_QMpolymorphic_testPpass_up(%[[EMBOX]]) fastmath<contract> : (!fir.class<none>) -> ()
+
 end module
 
 program test
   use polymorphic_test
   type(outer), allocatable :: o
   integer :: i(5)
   logical :: l(5)
   allocate(o)