[flang] Allow conversion from boxed derived type to fir.class

[clementval]

Summary

This patch updates the fir.convert operation's verifier to allow
conversion from !fir.box<!fir.type<T>> to !fir.class<!fir.type<T>>.

Other conversion involving fir.class are likely needed but will
be added when lowering needs them.

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/include/flang/Optimizer/Dialect/FIRType.h

 /// This class provides a shared interface for box and class types.
 class BaseBoxType : public mlir::Type {
 public:
   using mlir::Type::Type;
 
   /// Returns the element type of this box type.
   mlir::Type getEleTy() const;
 
+  /// Unwrap element type from fir.heap, fir.ptr and fir.array.
+  mlir::Type unwrapInnerType() const;
+
   /// Methods for support type inquiry through isa, cast, and dyn_cast.
   static bool classof(mlir::Type type);
 };
 
 } // namespace fir
 
 #define GET_TYPEDEF_CLASSES
 #include "flang/Optimizer/Dialect/FIROpsTypes.h.inc"

 
 /// Return true iff `ty` is the type of a POINTER entity or value.
 /// `isa_ref_type()` can be used to distinguish.
 bool isPointerType(mlir::Type ty);
 
 /// Return true iff `ty` is the type of an ALLOCATABLE entity or value.
 bool isAllocatableType(mlir::Type ty);
 
+/// Return true iff `ty` is the type of a boxed record type.
+/// e.g. !fir.box<!fir.type<derived>>
+bool isBoxedRecordType(mlir::Type ty);
+
 /// Return true iff `ty` is the type of an polymorphic entity or
 /// value.
 bool isPolymorphicType(mlir::Type ty);
 
 /// Return true iff `ty` is the type of an unlimited polymorphic entity or
 /// value.
 bool isUnlimitedPolymorphicType(mlir::Type ty);
 

flang/lib/Optimizer/Dialect/FIROps.cpp

if ((isPointerCompatible(inType) && isPointerCompatible(outType)) ||
       (isIntegerCompatible(inType) && isIntegerCompatible(outType)) ||
       (isIntegerCompatible(inType) && isFloatCompatible(outType)) ||
       (isFloatCompatible(inType) && isIntegerCompatible(outType)) ||
       (isFloatCompatible(inType) && isFloatCompatible(outType)) ||
       (isIntegerCompatible(inType) && isPointerCompatible(outType)) ||
       (isPointerCompatible(inType) && isIntegerCompatible(outType)) ||
       (inType.isa<fir::BoxType>() && outType.isa<fir::BoxType>()) ||
       (inType.isa<fir::BoxProcType>() && outType.isa<fir::BoxProcType>()) ||
-      (fir::isa_complex(inType) && fir::isa_complex(outType)))
+      (fir::isa_complex(inType) && fir::isa_complex(outType)) ||
+      (fir::isBoxedRecordType(inType) && fir::isPolymorphicType(outType)))
     return mlir::success();
   return emitOpError("invalid type conversion");
 }
 
 //===----------------------------------------------------------------------===//
 // CoordinateOp
 //===----------------------------------------------------------------------===//
 

flang/lib/Optimizer/Dialect/FIRType.cpp

 bool isAllocatableType(mlir::Type ty) {
   if (auto refTy = fir::dyn_cast_ptrEleTy(ty))
     ty = refTy;
   if (auto boxTy = ty.dyn_cast<fir::BaseBoxType>())
     return boxTy.getEleTy().isa<fir::HeapType>();
   return false;
 }
 
+bool isBoxedRecordType(mlir::Type ty) {
+  if (auto refTy = fir::dyn_cast_ptrEleTy(ty))
+    ty = refTy;
+  if (auto boxTy = ty.dyn_cast<fir::BoxType>()) {
+    if (boxTy.getEleTy().isa<fir::RecordType>())
+      return true;
+    mlir::Type innerType = boxTy.unwrapInnerType();
+    return innerType && innerType.isa<fir::RecordType>();
+  }
+  return false;
+}
+
 static bool isAssumedType(mlir::Type ty) {
   if (auto boxTy = ty.dyn_cast<fir::BoxType>()) {
     if (boxTy.getEleTy().isa<mlir::NoneType>())
       return true;
     if (auto seqTy = boxTy.getEleTy().dyn_cast<fir::SequenceType>())
       return seqTy.getEleTy().isa<mlir::NoneType>();
   }
   return false;

 
 bool isUnlimitedPolymorphicType(mlir::Type ty) {
   if (auto refTy = fir::dyn_cast_ptrEleTy(ty))
     ty = refTy;
   // CLASS(*)
   if (auto clTy = ty.dyn_cast<fir::ClassType>()) {
     if (clTy.getEleTy().isa<mlir::NoneType>())
       return true;
-    mlir::Type innerType =
-        llvm::TypeSwitch<mlir::Type, mlir::Type>(clTy.getEleTy())
-            .Case<fir::PointerType, fir::HeapType, fir::SequenceType>(
-                [](auto ty) {
-                  mlir::Type eleTy = ty.getEleTy();
-                  if (auto seqTy = eleTy.dyn_cast<fir::SequenceType>())
-                    return seqTy.getEleTy();
-                  return eleTy;
-                })
-            .Default([](mlir::Type) { return mlir::Type{}; });
-    return innerType.isa<mlir::NoneType>();
+    mlir::Type innerType = clTy.unwrapInnerType();
+    return innerType && innerType.isa<mlir::NoneType>();
   }
   // TYPE(*)
   return isAssumedType(ty);
 }
 
 bool isRecordWithAllocatableMember(mlir::Type ty) {
   if (auto recTy = ty.dyn_cast<fir::RecordType>())
     for (auto [field, memTy] : recTy.getTypeList()) {

 //===----------------------------------------------------------------------===//
 
 mlir::Type BaseBoxType::getEleTy() const {
   return llvm::TypeSwitch<fir::BaseBoxType, mlir::Type>(*this)
       .Case<fir::BoxType, fir::ClassType>(
           [](auto type) { return type.getEleTy(); });
 }
 
+mlir::Type BaseBoxType::unwrapInnerType() const {
+  return llvm::TypeSwitch<mlir::Type, mlir::Type>(getEleTy())
+      .Case<fir::PointerType, fir::HeapType, fir::SequenceType>([](auto ty) {
+        mlir::Type eleTy = ty.getEleTy();
+        if (auto seqTy = eleTy.dyn_cast<fir::SequenceType>())
+          return seqTy.getEleTy();
+        return eleTy;
+      })
+      .Default([](mlir::Type) { return mlir::Type{}; });
+}
+
 //===----------------------------------------------------------------------===//
 // FIROpsDialect
 //===----------------------------------------------------------------------===//
 
 void FIROpsDialect::registerTypes() {
   addTypes<BoxType, BoxCharType, BoxProcType, CharacterType, ClassType,
            fir::ComplexType, FieldType, HeapType, fir::IntegerType, LenType,
            LogicalType, LLVMPointerType, PointerType, RealType, RecordType,

flang/test/Lower/polymorphic.f90

 ! RUN: bbc -polymorphic-type -emit-fir %s -o - | FileCheck %s
 
 ! Tests various aspect of the lowering of polymorphic entities.
 
 module polymorphic_test
   type p1
     integer :: a
     integer :: b
+  contains
+    procedure :: print
   end type
 
   type, extends(p1) :: p2
     real :: c
   end type
 
   contains
 
   ! Test correct access to polymorphic entity component.
   subroutine component_access(p)
     class(p1) :: p
     print*, p%a
   end subroutine
 
 ! CHECK-LABEL: func.func @_QMpolymorphic_testPcomponent_access(
 ! CHECK-SAME: %[[P:.*]]: !fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>> {fir.bindc_name = "p"}) {
 ! CHECK: %[[FIELD:.*]] = fir.field_index a, !fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>
 ! CHECK: %[[COORD:.*]] = fir.coordinate_of %[[P]], %[[FIELD]] : (!fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>, !fir.field) -> !fir.ref<i32>
 ! CHECK: %[[LOAD:.*]] = fir.load %[[COORD]] : !fir.ref<i32>
 ! CHECK: %{{.*}} = fir.call @_FortranAioOutputInteger32(%{{.*}}, %[[LOAD]]) : (!fir.ref<i8>, i32) -> i1
 
+  subroutine print(this)
+    class(p1) :: this
+  end subroutine
+
+  ! Test passing fir.convert accept fir.box<DT> -> fir.class<DT>
+  subroutine check()
+    type(p1) :: t1
+    type(p2) :: t2
+    call t1%print()
+    call t2%print()
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMpolymorphic_testPcheck()
+! CHECK: %[[DT1:.*]] = fir.alloca !fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}> {bindc_name = "t1", uniq_name = "_QMpolymorphic_testFcheckEt1"}
+! CHECK: %[[DT2:.*]] = fir.alloca !fir.type<_QMpolymorphic_testTp2{a:i32,b:i32,c:f32}> {bindc_name = "t2", uniq_name = "_QMpolymorphic_testFcheckEt2"}
+! CHECK: %[[BOX1:.*]] = fir.embox %[[DT1]] : (!fir.ref<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>) -> !fir.box<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>
+! CHECK: %[[CLASS1:.*]] = fir.convert %[[BOX1]] : (!fir.box<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>) -> !fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>
+! CHECK: fir.call @_QMpolymorphic_testPprint(%[[CLASS1]]) : (!fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>) -> ()
+! CHECK: %[[BOX2:.*]] = fir.embox %[[DT2]] : (!fir.ref<!fir.type<_QMpolymorphic_testTp2{a:i32,b:i32,c:f32}>>) -> !fir.box<!fir.type<_QMpolymorphic_testTp2{a:i32,b:i32,c:f32}>>
+! CHECK: %[[CLASS2:.*]] = fir.convert %[[BOX2]] : (!fir.box<!fir.type<_QMpolymorphic_testTp2{a:i32,b:i32,c:f32}>>) -> !fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>
+! CHECK: fir.call @_QMpolymorphic_testPprint(%[[CLASS2]]) : (!fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>) -> ()
 end module

flang/unittests/Optimizer/FIRTypesTest.cpp

TEST_F(FIRTypesTest, isUnlimitedPolymorphicTypeTest) {
 
   // TYPE(*), DIMENSION(:)
   EXPECT_TRUE(fir::isUnlimitedPolymorphicType(fir::BoxType::get(seqNoneTy)));
 
   // false tests
   EXPECT_FALSE(fir::isUnlimitedPolymorphicType(noneTy));
   EXPECT_FALSE(fir::isUnlimitedPolymorphicType(seqNoneTy));
 }
+
+// Test fir::isBoxedRecordType from flang/Optimizer/Dialect/FIRType.h.
+TEST_F(FIRTypesTest, isBoxedRecordType) {
+  mlir::Type recTy = fir::RecordType::get(&context, "dt");
+  mlir::Type seqRecTy =
+      fir::SequenceType::get({fir::SequenceType::getUnknownExtent()}, recTy);
+  mlir::Type ty = fir::BoxType::get(recTy);
+  EXPECT_TRUE(fir::isBoxedRecordType(ty));
+  EXPECT_TRUE(fir::isBoxedRecordType(fir::ReferenceType::get(ty)));
+
+  // TYPE(T), ALLOCATABLE
+  ty = fir::BoxType::get(fir::HeapType::get(recTy));
+  EXPECT_TRUE(fir::isBoxedRecordType(ty));
+
+  // TYPE(T), POINTER
+  ty = fir::BoxType::get(fir::PointerType::get(recTy));
+  EXPECT_TRUE(fir::isBoxedRecordType(ty));
+
+  // TYPE(T), DIMENSION(10)
+  ty = fir::BoxType::get(fir::SequenceType::get({10}, recTy));
+  EXPECT_TRUE(fir::isBoxedRecordType(ty));
+
+  // TYPE(T), DIMENSION(:)
+  ty = fir::BoxType::get(seqRecTy);
+  EXPECT_TRUE(fir::isBoxedRecordType(ty));
+
+  EXPECT_FALSE(fir::isBoxedRecordType(fir::BoxType::get(
+      fir::ReferenceType::get(mlir::IntegerType::get(&context, 32)))));
+}