[flang] Handle fir.class pointer and allocatable in fir.dispatch code gen

[clementval]

Summary

fir.dispatch code generation was not handling fir.class pointer and
allocatable types. Update the code generation part to rertieve correctly the
the type info from those types.

Depends on D136426

[jeanPerier]

flang/lib/Optimizer/CodeGen/CodeGen.cpp

907

Is this handling array passed objects (I would expect this code to unwrap a potential sequence type) ?

[clementval]

flang/lib/Optimizer/CodeGen/CodeGen.cpp

907

As per C760 pass object needs to be scalar. There is an embox with tdesc done on the caller site.

[clementval]

flang/lib/Optimizer/CodeGen/CodeGen.cpp

907

Note that this constraint is currently missing in semantics.

[jeanPerier]

flang/lib/Optimizer/CodeGen/CodeGen.cpp

907

OK, makes sense then, thanks for explaining

flang/lib/Lower/ConvertExpr.cpp

if (caller.requireDispatchCall()) {
             operands[*passArg], operands, builder.getI32IntegerAttr(*passArg));
       } else {
         // NOPASS
         const Fortran::evaluate::Component *component =
             caller.getCallDescription().proc().GetComponent();
         assert(component && "expect component for type-bound procedure call.");
         fir::ExtendedValue pass =
             symMap.lookupSymbol(component->GetFirstSymbol()).toExtendedValue();
+        mlir::Value passObject = fir::getBase(pass);
+        if (fir::isa_ref_type(passObject.getType()))
+          passObject = builder.create<fir::ConvertOp>(
+              loc,
+              passObject.getType().dyn_cast<fir::ReferenceType>().getEleTy(),
+              passObject);
         dispatch = builder.create<fir::DispatchOp>(
             loc, funcType.getResults(), builder.getStringAttr(procName),
-            fir::getBase(pass), operands, nullptr);
+            passObject, operands, nullptr);
       }
       callResult = dispatch.getResult(0);
       callNumResults = dispatch.getNumResults();
     } else {
       // Standard procedure call with fir.call.
       auto call = builder.create<fir::CallOp>(loc, funcType.getResults(),
                                               funcSymbolAttr, operands);
       callResult = call.getResult(0);

flang/lib/Optimizer/CodeGen/CodeGen.cpp

 #include "mlir/Dialect/LLVMIR/LLVMDialect.h"
 #include "mlir/Dialect/OpenMP/OpenMPDialect.h"
 #include "mlir/IR/BuiltinTypes.h"
 #include "mlir/IR/Matchers.h"
 #include "mlir/Pass/Pass.h"
 #include "mlir/Pass/PassManager.h"
 #include "mlir/Target/LLVMIR/ModuleTranslation.h"
 #include "llvm/ADT/ArrayRef.h"
+#include "llvm/ADT/TypeSwitch.h"
 
 namespace fir {
 #define GEN_PASS_DEF_FIRTOLLVMLOWERING
 #include "flang/Optimizer/CodeGen/CGPasses.h.inc"
 } // namespace fir
 
 #define DEBUG_TYPE "flang-codegen"
 
struct DispatchOpConversion : public FIROpConversion<fir::DispatchOp> {
   mlir::LogicalResult
   matchAndRewrite(fir::DispatchOp dispatch, OpAdaptor adaptor,
                   mlir::ConversionPatternRewriter &rewriter) const override {
     mlir::Location loc = dispatch.getLoc();
 
     if (bindingTables.empty())
       return emitError(loc) << "no binding tables found";
 
-    if (dispatch.getObject()
-            .getType()
-            .getEleTy()
-            .isa<fir::HeapType, fir::PointerType>())
-      TODO(loc,
-           "fir.dispatch with allocatable or pointer polymorphic entities");
-
     // Get derived type information.
-    auto declaredType = dispatch.getObject().getType().getEleTy();
+    auto declaredType = llvm::TypeSwitch<mlir::Type, mlir::Type>(
+                            dispatch.getObject().getType().getEleTy())
+                            .Case<fir::PointerType, fir::HeapType>(
+                                [](auto p) { return p.getEleTy(); })
+                            .Default([](mlir::Type t) { return t; });
+
     assert(declaredType.isa<fir::RecordType>() && "expecting fir.type");
     auto recordType = declaredType.dyn_cast<fir::RecordType>();
     std::string typeDescName =
         fir::NameUniquer::getTypeDescriptorName(recordType.getName());
     std::string typeDescBindingTableName =
         fir::NameUniquer::getTypeDescriptorBindingTableName(
             recordType.getName());
 

flang/test/Lower/allocatable-polymorphic.f90

 ! RUN: bbc -polymorphic-type -emit-fir %s -o - | FileCheck %s
 ! RUN: bbc -polymorphic-type -emit-fir %s -o - | tco | FileCheck %s --check-prefix=LLVM
 
 module poly
   type p1
     integer :: a
     integer :: b
+  contains
+    procedure, nopass :: proc1 => proc1_p1
   end type
 
   type, extends(p1) :: p2
     integer :: c
+  contains
+      procedure, nopass :: proc1 => proc1_p2
   end type
+
+contains
+  subroutine proc1_p1()
+    print*, 'call proc1_p1'
+  end subroutine
+
+  subroutine proc1_p2()
+    print*, 'call proc1_p2'
+  end subroutine
 end module
 
 program test_allocatable
   use poly
 
   class(p1), allocatable :: p
   class(p1), allocatable :: c1, c2
   class(p1), allocatable, dimension(:) :: c3, c4
 
   allocate(p) ! allocate as p1
 
   allocate(p1::c1)
   allocate(p2::c2)
 
   allocate(p1::c3(10))
   allocate(p2::c4(20))
 
+  call c1%proc1()
+  call c2%proc1()
 end
 
 ! CHECK-LABEL: func.func @_QQmain()
 
 ! CHECK-DAG: %[[C1:.*]] = fir.address_of(@_QFEc1) : !fir.ref<!fir.class<!fir.heap<!fir.type<_QMpolyTp1{a:i32,b:i32}>>>>
 ! CHECK-DAG: %[[C2:.*]] = fir.address_of(@_QFEc2) : !fir.ref<!fir.class<!fir.heap<!fir.type<_QMpolyTp1{a:i32,b:i32}>>>>
 ! CHECK-DAG: %[[C3:.*]] = fir.address_of(@_QFEc3) : !fir.ref<!fir.class<!fir.heap<!fir.array<?x!fir.type<_QMpolyTp1{a:i32,b:i32}>>>>>
 ! CHECK-DAG: %[[C4:.*]] = fir.address_of(@_QFEc4) : !fir.ref<!fir.class<!fir.heap<!fir.array<?x!fir.type<_QMpolyTp1{a:i32,b:i32}>>>>>