[flang] Add conditional rebox when passing fir.box to optional fir.class

[clementval]

Summary

When a !fir.box<> is passed as an actual argument to an optional
!fir.class<> dummy it needs a fir.rebox in order to propagate
the dynamic type information.
The fir.rebox needs to happen only on present argument.

[jeanPerier]

flang/test/Lower/polymorphic.f90

801

There is a test failure here.

[clementval]

Fix test

[jeanPerier]

LGTM

flang/lib/Lower/ConvertExpr.cpp

for (const Fortran::lower::CallInterface<
           /// has the dummy attributes in BIND(C) contexts.
           mlir::Value box = builder.createBox(
               loc, fir::factory::genMutableBoxRead(builder, loc, mutableBox));
 
           // NULL() passed as argument is passed as a !fir.box<none>. Since
           // select op requires the same type for its two argument, convert
           // !fir.box<none> to !fir.class<none> when the argument is
           // polymorphic.
-          if (fir::isBoxNone(box.getType()) && fir::isPolymorphicType(argTy))
+          if (fir::isBoxNone(box.getType()) && fir::isPolymorphicType(argTy)) {
             box = builder.createConvert(
                 loc,
                 fir::ClassType::get(mlir::NoneType::get(builder.getContext())),
                 box);
+          } else if (box.getType().isa<fir::BoxType>() &&
+                     fir::isPolymorphicType(argTy)) {
+            box = builder.create<fir::ReboxOp>(loc, argTy, box, mlir::Value{},
+                                               /*slice=*/mlir::Value{});
+          }
 
           // Need the box types to be exactly similar for the selectOp.
           mlir::Value convertedBox = builder.createConvert(loc, argTy, box);
           caller.placeInput(arg, builder.create<mlir::arith::SelectOp>(
                                      loc, isAllocated, convertedBox, absent));
         } else {
           // Make sure a variable address is only passed if the expression is
           // actually a variable.
           mlir::Value box =
               Fortran::evaluate::IsVariable(*expr)
                   ? builder.createBox(loc, genBoxArg(*expr),
                                       fir::isPolymorphicType(argTy))
                   : builder.createBox(getLoc(), genTempExtAddr(*expr),
                                       fir::isPolymorphicType(argTy));
+
+          if (box.getType().isa<fir::BoxType>() &&
+              fir::isPolymorphicType(argTy)) {
+            // Rebox can only be performed on a present argument.
+            if (arg.isOptional()) {
+              mlir::Value isPresent = genActualIsPresentTest(builder, loc, box);
+              box =
+                  builder
+                      .genIfOp(loc, {argTy}, isPresent, /*withElseRegion=*/true)
+                      .genThen([&]() {
+                        auto rebox = builder
+                                         .create<fir::ReboxOp>(
+                                             loc, argTy, box, mlir::Value{},
+                                             /*slice=*/mlir::Value{})
+                                         .getResult();
+                        builder.create<fir::ResultOp>(loc, rebox);
+                      })
+                      .genElse([&]() {
+                        auto absent = builder.create<fir::AbsentOp>(loc, argTy)
+                                          .getResult();
+                        builder.create<fir::ResultOp>(loc, absent);
+                      })
+                      .getResults()[0];
+            } else {
+              box = builder.create<fir::ReboxOp>(loc, argTy, box, mlir::Value{},
+                                                 /*slice=*/mlir::Value{});
+            }
+          }
           caller.placeInput(arg, box);
         }
       } else if (arg.passBy == PassBy::AddressAndLength) {
         ExtValue argRef = genExtAddr(*expr);
         caller.placeAddressAndLengthInput(arg, fir::getBase(argRef),
                                           fir::getLen(argRef));
       } else if (arg.passBy == PassBy::CharProcTuple) {
         ExtValue argRef = genExtAddr(*expr);

flang/lib/Optimizer/CodeGen/CodeGen.cpp

struct EmboxCommonConversion : public FIROpConversion<OP> {
   }
   static bool isDerivedTypeWithLenParams(fir::BaseBoxType boxTy) {
     auto recTy = unwrapIfDerived(boxTy);
     return recTy && recTy.getNumLenParams() > 0;
   }
   static bool isDerivedType(fir::BaseBoxType boxTy) {
     return static_cast<bool>(unwrapIfDerived(boxTy));
   }
+  static bool hasAddendum(fir::BaseBoxType boxTy) {
+    return static_cast<bool>(unwrapIfDerived(boxTy)) ||
+           fir::isUnlimitedPolymorphicType(boxTy);
+  }
 
   // Get the element size and CFI type code of the boxed value.
   std::tuple<mlir::Value, mlir::Value> getSizeAndTypeCode(
       mlir::Location loc, mlir::ConversionPatternRewriter &rewriter,
       mlir::Type boxEleTy, mlir::ValueRange lenParams = {}) const {
     auto i64Ty = mlir::IntegerType::get(rewriter.getContext(), 64);
     auto getKindMap = [&]() -> fir::KindMapping & {
       return this->lowerTy().getKindMap();
struct EmboxCommonConversion : public FIROpConversion<OP> {
 
   std::tuple<fir::BaseBoxType, mlir::Value, mlir::Value>
   consDescriptorPrefix(fir::cg::XReboxOp box, mlir::Value loweredBox,
                        mlir::ConversionPatternRewriter &rewriter, unsigned rank,
                        mlir::ValueRange lenParams,
                        mlir::Value typeDesc = {}) const {
     auto loc = box.getLoc();
     auto boxTy = box.getType().dyn_cast<fir::BaseBoxType>();
+    auto inputBoxTy = box.getBox().getType().dyn_cast<fir::BaseBoxType>();
     llvm::SmallVector<mlir::Value> typeparams = lenParams;
     if (!box.getSubstr().empty() && fir::hasDynamicSize(boxTy.getEleTy()))
       typeparams.push_back(box.getSubstr()[1]);
 
     auto [eleSize, cfiTy] =
         getSizeAndTypeCode(loc, rewriter, boxTy.getEleTy(), typeparams);
 
-    // Reboxing a polymorphic entities. eleSize and type code need to
+    // Reboxing to a polymorphic entity. eleSize and type code need to
     // be retrived from the initial box and propagated to the new box.
-    if (fir::isPolymorphicType(boxTy) &&
-        fir::isPolymorphicType(box.getBox().getType())) {
+    // If the initial box has an addendum, the type desc must be propagated as
+    // well.
+    if (fir::isPolymorphicType(boxTy)) {
       mlir::Type idxTy = this->lowerTy().indexType();
       eleSize =
           this->getElementSizeFromBox(loc, idxTy, boxTy, loweredBox, rewriter);
       cfiTy = this->getValueFromBox(loc, boxTy, loweredBox, cfiTy.getType(),
                                     rewriter, kTypePosInBox);
+      // TODO: For initial box that are unlimited polymorphic entities, this
+      // code must be made conditional because unlimited polymorphic entities
+      // with intrinsic type spec does not have addendum.
+      if (hasAddendum(inputBoxTy))
         typeDesc = this->loadTypeDescAddress(loc, box.getBox().getType(),
                                              loweredBox, rewriter);
     }
 
     auto mod = box->template getParentOfType<mlir::ModuleOp>();
     mlir::Value descriptor =
         populateDescriptor(loc, mod, boxTy, box.getBox().getType(), rewriter,
                            rank, eleSize, cfiTy, typeDesc);
 
     return {boxTy, descriptor, eleSize};

flang/test/Lower/polymorphic.f90

 ! CHECK: %[[C0:.*]] = arith.constant 0 : i64
 ! CHECK: %[[IS_ALLOCATED_OR_ASSOCIATED:.*]] = arith.cmpi ne, %[[BOX_ADDR_I64]], %[[C0]] : i64
 ! CHECK: %[[ABSENT:.*]] = fir.absent !fir.class<none>
 ! CHECK: %[[BOX_NONE:.*]] = fir.load %[[NULL_BOX_NONE]] : !fir.ref<!fir.box<none>>
 ! CHECK: %[[CLASS_NONE:.*]] = fir.convert %[[BOX_NONE]] : (!fir.box<none>) -> !fir.class<none>
 ! CHECK: %[[ARG:.*]] = arith.select %[[IS_ALLOCATED_OR_ASSOCIATED]], %[[CLASS_NONE]], %[[ABSENT]] : !fir.class<none>
 ! CHECK: fir.call @_QMpolymorphic_testPsub_with_poly_optional(%[[ARG]]) {{.*}} : (!fir.class<none>) -> ()
 
+  subroutine sub_with_poly_array_optional(a)
+    class(*), optional :: a(:)
+  end subroutine
+
+  subroutine test_call_with_pointer_to_optional()
+    real, pointer :: p(:)
+    call sub_with_poly_array_optional(p)
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMpolymorphic_testPtest_call_with_pointer_to_optional() {
+! CHECK: %[[P:.*]] = fir.alloca !fir.box<!fir.ptr<!fir.array<?xf32>>> {bindc_name = "p", uniq_name = "_QMpolymorphic_testFtest_call_with_pointer_to_optionalEp"}
+! CHECK: %[[IS_ALLOCATED_OR_ASSOCIATED:.*]] = arith.cmpi ne
+! CHECK: %[[ABSENT:.*]] = fir.absent !fir.class<!fir.array<?xnone>>
+! CHECK: %[[LOAD_P:.*]] = fir.load %[[P]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+! CHECK: %[[REBOX:.*]] = fir.rebox %[[LOAD_P]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>) -> !fir.class<!fir.array<?xnone>>
+! CHECK: %[[ARG:.*]] = arith.select %[[IS_ALLOCATED_OR_ASSOCIATED]], %[[REBOX]], %[[ABSENT]] : !fir.class<!fir.array<?xnone>>
+! CHECK: fir.call @_QMpolymorphic_testPsub_with_poly_array_optional(%[[ARG]]) {{.*}} : (!fir.class<!fir.array<?xnone>>) -> ()
+
+  subroutine sub_with_real_pointer_optional(p)
+    real, optional :: p(:)
+    call sub_with_poly_array_optional(p)
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMpolymorphic_testPsub_with_real_pointer_optional(
+! CHECK-SAME: %[[P:.*]]: !fir.box<!fir.array<?xf32>> {fir.bindc_name = "p", fir.optional}) {
+! CHECK: %[[IS_PRESENT:.*]] = fir.is_present %[[P]] : (!fir.box<!fir.array<?xf32>>) -> i1
+! CHECK: %[[BOX:.*]] = fir.if %[[IS_PRESENT]] -> (!fir.class<!fir.array<?xnone>>) {
+! CHECK:   %[[REBOX:.*]] = fir.rebox %[[P]] : (!fir.box<!fir.array<?xf32>>) -> !fir.class<!fir.array<?xnone>>
+! CHECK:   fir.result %[[REBOX]] : !fir.class<!fir.array<?xnone>>
+! CHECK: } else {
+! CHECK:   %[[ABSENT:.*]] = fir.absent !fir.class<!fir.array<?xnone>>
+! CHECK:   fir.result %[[ABSENT]] : !fir.class<!fir.array<?xnone>>
+! CHECK: }
+! CHECK: fir.call @_QMpolymorphic_testPsub_with_poly_array_optional(%[[BOX]]) {{.*}} : (!fir.class<!fir.array<?xnone>>) -> ()
+
 end module
 
 program test
   use polymorphic_test
   type(outer), allocatable :: o
   integer :: i(5)
   logical :: l(5)
   allocate(o)