[flang] Handle polymorphic passed object in host association

[clementval]

Summary

Polymorphic entities are always emboxed. This patch
handles host association of polyrmophic entities as passed object.

[jeanPerier]

Other than the nit about the edge case, looks good to me.

flang/lib/Lower/HostAssociations.cpp

248

Can you add a TODO if this is a polymorphic array with non default lower bounds ?

I think this code would not handle it correctly since the fir.class may not contain the lower bound values (and cares needs to be taken to shoe them in if the fir.class is OPTIONAL). HLFIR variables will probably help because the lower bound "shoe-horning" will be handled in the hlfir.declare.

[clementval]

Add TODO for polymorphic array with non default lower bound

[PeteSteinfeld]

All builds and tests correctly and is formatted correctly.

[clementval]

Rebase

[clementval]

Fix rebase

[clementval]

Fix patch application

[jeanPerier]

LGTM, thanks

flang/lib/Lower/HostAssociations.cpp

 /// Is \p sym a derived type entity with length parameters ?
 static bool isDerivedWithLenParameters(const Fortran::semantics::Symbol &sym) {
   if (const auto *declTy = sym.GetType())
     if (const auto *derived = declTy->AsDerived())
       return Fortran::semantics::CountLenParameters(*derived) != 0;
   return false;
 }
 
+/// Class defining how polymorphic entities are captured in internal procedures.
+/// Polymorphic entities are always boxed as a fir.class box.
+class CapturedPolymorphic : public CapturedSymbols<CapturedPolymorphic> {
+public:
+  static mlir::Type getType(Fortran::lower::AbstractConverter &converter,
+                            const Fortran::semantics::Symbol &sym) {
+    return fir::ClassType::get(converter.genType(sym));
+  }
+  static void instantiateHostTuple(const InstantiateHostTuple &args,
+                                   Fortran::lower::AbstractConverter &converter,
+                                   const Fortran::semantics::Symbol &) {
+    fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+    mlir::Type typeInTuple = fir::dyn_cast_ptrEleTy(args.addrInTuple.getType());
+    assert(typeInTuple && "addrInTuple must be an address");
+    mlir::Value castBox = builder.createConvert(args.loc, typeInTuple,
+                                                fir::getBase(args.hostValue));
+    builder.create<fir::StoreOp>(args.loc, castBox, args.addrInTuple);
+  }
+  static void getFromTuple(const GetFromTuple &args,
+                           Fortran::lower::AbstractConverter &converter,
+                           const Fortran::semantics::Symbol &sym,
+                           const Fortran::lower::BoxAnalyzer &ba) {
+    args.symMap.addSymbol(sym, args.valueInTuple);
+  }
+};
+
 /// Class defining how allocatable and pointers entities are captured in
 /// internal procedures. Allocatable and pointers are simply captured by placing
 /// their !fir.ref<fir.box<>> address in the host tuple.
 class CapturedAllocatableAndPointer
     : public CapturedSymbols<CapturedAllocatableAndPointer> {
 public:
   static mlir::Type getType(Fortran::lower::AbstractConverter &converter,
                             const Fortran::semantics::Symbol &sym) {
walkCaptureCategories(T visitor, Fortran::lower::AbstractConverter &converter,
   Fortran::lower::BoxAnalyzer ba;
   // Do not analyze procedures, they may be subroutines with no types that would
   // crash the analysis.
   if (Fortran::semantics::IsProcedure(sym))
     return CapturedProcedure::visit(visitor, converter, sym, ba);
   ba.analyze(sym);
   if (Fortran::semantics::IsAllocatableOrPointer(sym))
     return CapturedAllocatableAndPointer::visit(visitor, converter, sym, ba);
+  if (Fortran::semantics::IsPolymorphic(sym)) {
+    if (ba.isArray() && !ba.lboundIsAllOnes())
+      TODO(converter.genLocation(sym.name()),
+           "polymorphic array with non default lower bound");
+    return CapturedPolymorphic::visit(visitor, converter, sym, ba);
+  }
   if (ba.isArray())
     return CapturedArrays::visit(visitor, converter, sym, ba);
   if (ba.isChar())
     return CapturedCharacterScalars::visit(visitor, converter, sym, ba);
   assert(ba.isTrivial() && "must be trivial scalar");
   return CapturedSimpleScalars::visit(visitor, converter, sym, ba);
 }
 

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
     procedure :: assign_p1_int
     generic :: assignment(=) => assign_p1_int
+    procedure :: host_assoc
   end type
 
   type, extends(p1) :: p2
     real :: c
   end type
 
   type r1
     real, pointer :: rp(:) => null()
module polymorphic_test
 
   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_testPhost_assoc(
+! CHECK-SAME: %[[THIS:.*]]: !fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>) {
+! CHECK: %[[TUPLE:.*]] = fir.alloca tuple<!fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>
+! CHECK: %[[POS_IN_TUPLE:.*]] = arith.constant 0 : i32
+! CHECK: %[[COORD_OF_CLASS:.*]] = fir.coordinate_of %[[TUPLE]], %[[POS_IN_TUPLE]] : (!fir.ref<tuple<!fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>>, i32) -> !fir.ref<!fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>
+! CHECK: fir.store %[[THIS]] to %[[COORD_OF_CLASS]] : !fir.ref<!fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>
+! CHECK: fir.call @_QMpolymorphic_testFhost_assocPinternal(%[[TUPLE]]) {{.*}} : (!fir.ref<tuple<!fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>>) -> ()
+
   ! 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:   %[[EMBOXED:.*]] = fir.embox %10#0 : (!fir.ref<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>) -> !fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>
 ! CHECK:   fir.store %[[FETCH_INT]] to %[[INT]] : !fir.ref<i32>
 ! CHECK:   fir.call @_QMpolymorphic_testPassign_p1_int(%[[EMBOXED]], %[[INT]]) fastmath<contract> : (!fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>, !fir.ref<i32>) -> ()
 ! CHECK:   fir.result %[[ARRAY_MOD]]#1 : !fir.array<3x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>
 ! CHECK: }
 ! CHECK: fir.array_merge_store %[[LOAD_PA]], %[[DO_RES]] to %[[PA]] : !fir.array<3x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>, !fir.array<3x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>, !fir.ref<!fir.array<3x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>
 ! CHECK: return
 
+  subroutine host_assoc(this)
+    class(p1) :: this
+    
+    call internal
+  contains
+    subroutine internal
+      print*, this%a, this%b
+    end subroutine
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMpolymorphic_testFhost_assocPinternal(
+! CHECK-SAME: %[[TUPLE:.*]]: !fir.ref<tuple<!fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>> {fir.host_assoc}) {
+! CHECK: %[[POS_IN_TUPLE:.*]] = arith.constant 0 : i32
+! CHECK: %[[COORD_OF_CLASS:.*]] = fir.coordinate_of %[[TUPLE]], %[[POS_IN_TUPLE]] : (!fir.ref<tuple<!fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>>, i32) -> !fir.ref<!fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>
+! CHECK: %[[CLASS:.*]] = fir.load %[[COORD_OF_CLASS]] : !fir.ref<!fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>
+! CHECK: %[[FIELD_A:.*]] = fir.field_index a, !fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>
+! CHECK: %[[COORD_A:.*]] = fir.coordinate_of %[[CLASS]], %[[FIELD_A]] : (!fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>, !fir.field) -> !fir.ref<i32>
+! CHECK: %[[A:.*]] = fir.load %[[COORD_A]] : !fir.ref<i32>
+! CHECK: %{{.*}} = fir.call @_FortranAioOutputInteger32(%{{.*}}, %[[A]]) {{.*}} : (!fir.ref<i8>, i32) -> i1
+! CHECK: %[[FIELD_B:.*]] = fir.field_index b, !fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>
+! CHECK: %[[COORD_B:.*]] = fir.coordinate_of %[[CLASS]], %[[FIELD_B]] : (!fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>, !fir.field) -> !fir.ref<i32>
+! CHECK: %[[B:.*]] = fir.load %[[COORD_B]] : !fir.ref<i32>
+! CHECK: %{{.*}} = fir.call @_FortranAioOutputInteger32(%{{.*}}, %[[B]]) {{.*}} : (!fir.ref<i8>, i32) -> i1
+
 end module