[flang] Lower type-bound procedure call needing dynamic dispatch to fir.dispatch

[clementval]

Summary

Lower call with polymorphic entities to fir.dispatch operation. This patch only
focus one lowering with simple scalar polymorphic entities. A follow-up patch
will deal with allocatble, pointer and array of polymorphic entities as they
require box manipulation for the passed-object.

[jeanPerier]

flang/lib/Lower/ConvertExpr.cpp

2756

What about changing the if (ultimateSymbol.attrs().test(Fortran::semantics::Attr::NOPASS) into if ( std::optional<unsigned> passArg = caller.getPassArgIndex()) { ... (and reverse the regions) so that there is no questions about "*passArg" being safe ?

flang/lib/Lower/Mangler.cpp

159

This may be introducing some weird collision risks.

As I understand it, we do not care about the mangling here since dispatch uses the fortran name. I guess you need this because the CallInterface wants to declare some fir.func op that is not actually used.

The collision risk I see should be illustrated by the program below that I think will hit a bad convert from fir.ref<f32> to fir.box<> in a piece of code that has nothing to do with your changes.

module m
  type p1
    integer :: a
    integer :: b
  contains
    procedure, nopass :: foo => bar
  end type

contains
  subroutine check_dispatch(p, x)
      class(p1) :: p
      real :: x(:)
      call p%foo(x)
  end subroutine
  subroutine bar(x)
    real :: x(:)
  end subroutine 
end module

 real :: x
 ! unrelated to foo from module m, yet due to function name clash in MLIR,
 ! I think it will collide and use the same argument types of bar,
 ! trying to cast the argument to a fir.box as if the mismatch was a simple implicit interface issue.
 call foo(x) 
end

My suggestion is to skip the func creation in the CalllerInterface (like this done for function pointers).

flang/lib/Optimizer/Builder/FIRBuilder.cpp

472

OK, the pattern you showed me makes more sense to me now. But this code is broken for now here, right ? How can the new embox get the correct dynamic type from the original fir.coordinate_of fir.class base ?

[clementval]

flang/lib/Lower/ConvertExpr.cpp

2756

Yeah it works too. I'll update it.

flang/lib/Lower/Mangler.cpp

159

Right it was needed only because of the func creation. I'll just skip it.

flang/lib/Optimizer/Builder/FIRBuilder.cpp

472

Yes this is left over from a previous attempt. I'll remove it from this patch and add it back when it is functional.

[clementval]

Address review comments

[clementval]

flang/lib/Lower/Mangler.cpp

159

Using the actual procedure name for mangling should also work and avoid collision.

[PeteSteinfeld]

Jean is the expert on the content, but I can confirm that all builds and tests correctly and looks good.

[jeanPerier]

flang/lib/Lower/Mangler.cpp

159

Why not, but then I think this should use return mangleName(procBinding.symbol(), keepExternalInScope) so that the scope is correctly mangled. Otherwise, I think this may still conflict if you update "bar" in my example above to be called "foo" (BTW, I think you can use the lambda argument directly for the details instead of getting it back from the ultimate symbol).

One point where I am less sure of, is what would happen with DEFERRED procedures. They do not exist (the type extending the abstract type will actually define the bindings). So I am not sure if this can lead to some weird scenario. I could not find one, because I think whatever conflicting procedure in that case would be declared before the dispatch call is processed (because it would not be possible to call a procedure with such name with an implicit procedure, and only implicit call lead to "on the fly" func declaration attempts).

You might still want to double check this is OK:

module m
  interface
    subroutine bar(x)
      real :: x(:)
    end subroutine
  end interface
  type, abstract :: p1
    integer :: a
    integer :: b
  contains
    procedure(bar), deferred, nopass :: foo 
  end type

contains
  subroutine check_dispatch(p, x)
      class(p1) :: p
      real :: x(:)
      call p%foo(x)
  end subroutine

  subroutine foo(x)
    real :: x
  end subroutine
end module

 use m
 real :: x
 call foo(x) 
end

[clementval]

Address review comment

[clementval]

flang/lib/Lower/Mangler.cpp

159

I updated to return mangleName. I'm not finding one either. The above example behave correctly with the current lowering so I guess we should be fine unless we find another corner case.

[clementval]

Add test with deferred tbp

[jeanPerier]

LGTM, thanks for addressing the comments.

flang/include/flang/Lower/CallInterface.h

public:
   const Fortran::semantics::SubprogramDetails *getInterfaceDetails() const;
 
   bool isMainProgram() const { return false; }
 
   /// Returns true if this is a call to a procedure pointer of a dummy
   /// procedure.
   bool isIndirectCall() const;
 
+  /// Returns true if this is a call of a type-bound procedure with a
+  /// polymorphic entity.
+  bool requireDispatchCall() const;
+
+  /// Get the passed-object argument index. nullopt if there is no passed-object
+  /// index.
+  std::optional<unsigned> getPassArgIndex() const;
+
   /// Return the procedure symbol if this is a call to a user defined
   /// procedure.
   const Fortran::semantics::Symbol *getProcedureSymbol() const;
 
   /// Helpers to place the lowered arguments at the right place once they
   /// have been lowered.
   void placeInput(const PassedEntity &passedEntity, mlir::Value arg);
   void placeAddressAndLengthInput(const PassedEntity &passedEntity,
public:
   Fortran::lower::pft::FunctionLikeUnit &getCallDescription() const {
     return funit;
   }
 
   /// On the callee side it does not matter whether the procedure is
   /// called through pointers or not.
   bool isIndirectCall() const { return false; }
 
+  /// On the callee side it does not matter whether the procedure is called
+  /// through dynamic dispatch or not.
+  bool requireDispatchCall() const { return false; };
+
   /// Return the procedure symbol if this is a call to a user defined
   /// procedure.
   const Fortran::semantics::Symbol *getProcedureSymbol() const;
 
   /// Add mlir::func::FuncOp entry block and map fir block arguments to Fortran
   /// dummy argument symbols.
   mlir::func::FuncOp addEntryBlockAndMapArguments();
 

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

inline unsigned getRankOfShapeType(mlir::Type t) {
   if (auto shTy = t.dyn_cast<fir::ShapeShiftType>())
     return shTy.getRank();
   if (auto shTy = t.dyn_cast<fir::ShiftType>())
     return shTy.getRank();
   return 0;
 }
 
 /// Get the memory reference type of the data pointer from the box type,
-inline mlir::Type boxMemRefType(fir::BoxType t) {
+inline mlir::Type boxMemRefType(fir::BaseBoxType t) {
   auto eleTy = t.getEleTy();
   if (!eleTy.isa<fir::PointerType, fir::HeapType>())
     eleTy = fir::ReferenceType::get(t);
   return eleTy;
 }
 
 /// If `t` is a SequenceType return its element type, otherwise return `t`.
 inline mlir::Type unwrapSequenceType(mlir::Type t) {

flang/lib/Lower/CallInterface.cpp

 
 bool Fortran::lower::CallerInterface::isIndirectCall() const {
   if (const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol())
     return Fortran::semantics::IsPointer(*symbol) ||
            Fortran::semantics::IsDummy(*symbol);
   return false;
 }
 
+bool Fortran::lower::CallerInterface::requireDispatchCall() const {
+  // calls with NOPASS attribute still have their component so check if it is
+  // polymorphic.
+  if (const Fortran::evaluate::Component *component =
+          procRef.proc().GetComponent()) {
+    if (Fortran::semantics::IsPolymorphic(component->GetFirstSymbol()))
+      return true;
+  }
+  // calls with PASS attribute have the passed-object already set in its
+  // arguments. Just check if their is one.
+  std::optional<unsigned> passArg = getPassArgIndex();
+  if (passArg)
+    return true;
+  return false;
+}
+
+std::optional<unsigned>
+Fortran::lower::CallerInterface::getPassArgIndex() const {
+  unsigned passArgIdx = 0;
+  std::optional<unsigned> passArg = std::nullopt;
+  for (const auto &arg : getCallDescription().arguments()) {
+    if (arg && arg->isPassedObject()) {
+      passArg = passArgIdx;
+      break;
+    }
+    ++passArgIdx;
+  }
+  return passArg;
+}
+
 const Fortran::semantics::Symbol *
 Fortran::lower::CallerInterface::getIfIndirectCallSymbol() const {
   if (const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol())
     if (Fortran::semantics::IsPointer(*symbol) ||
         Fortran::semantics::IsDummy(*symbol))
       return symbol;
   return nullptr;
 }

flang/lib/Lower/ConvertExpr.cpp

for (const auto &subsc : llvm::enumerate(aref.subscript())) {
       assert(fir::isUnboxedValue(subVal) && "subscript must be simple scalar");
       mlir::Value val = fir::getBase(subVal);
       mlir::Type ty = val.getType();
       mlir::Value lb = getLBound(array, subsc.index(), ty);
       args.push_back(builder.create<mlir::arith::SubIOp>(loc, ty, val, lb));
     }
 
     mlir::Value base = fir::getBase(array);
-    auto seqTy =
-        fir::dyn_cast_ptrOrBoxEleTy(base.getType()).cast<fir::SequenceType>();
+    mlir::Type eleTy = fir::dyn_cast_ptrOrBoxEleTy(base.getType());
+    if (auto classTy = eleTy.dyn_cast<fir::ClassType>())
+      eleTy = classTy.getEleTy();
+    auto seqTy = eleTy.cast<fir::SequenceType>();
     assert(args.size() == seqTy.getDimension());
     mlir::Type ty = builder.getRefType(seqTy.getEleTy());
     auto addr = builder.create<fir::CoordinateOp>(loc, ty, base, args);
     return fir::factory::arrayElementToExtendedValue(builder, loc, array, addr);
   }
 
   /// Lower an ArrayRef to a fir.coordinate_of using an element offset instead
   /// of array indexes.
for (auto [fst, snd] :
       }
       operands.push_back(cast);
     }
 
     // Add host associations as necessary.
     if (addHostAssociations)
       operands.push_back(converter.hostAssocTupleValue());
 
+    mlir::Value callResult;
+    unsigned callNumResults;
+    if (caller.requireDispatchCall()) {
+      // Procedure call requiring a dynamic dispatch. Call is created with
+      // fir.dispatch.
+
+      // Get the raw procedure name. The procedure name is not mangled in the
+      // binding table.
+      const auto &ultimateSymbol =
+          caller.getCallDescription().proc().GetSymbol()->GetUltimate();
+      auto procName = toStringRef(ultimateSymbol.name());
+
+      fir::DispatchOp dispatch;
+      if (std::optional<unsigned> passArg = caller.getPassArgIndex()) {
+        // PASS, PASS(arg-name)
+        dispatch = builder.create<fir::DispatchOp>(
+            loc, funcType.getResults(), procName, 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();
+        dispatch = builder.create<fir::DispatchOp>(loc, funcType.getResults(),
+                                                   procName, fir::getBase(pass),
+                                                   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);
+      callNumResults = call.getNumResults();
+    }
 
     if (caller.mustSaveResult())
-      builder.create<fir::SaveResultOp>(loc, call.getResult(0),
+      builder.create<fir::SaveResultOp>(loc, callResult,
                                         fir::getBase(allocatedResult.value()),
                                         arrayResultShape, resultLengths);
 
     if (allocatedResult) {
       allocatedResult->match(
           [&](const fir::MutableBoxValue &box) {
             if (box.isAllocatable()) {
               // 9.7.3.2 point 4. Finalize allocatables.
               fir::FirOpBuilder *bldr = &converter.getFirOpBuilder();
               stmtCtx.attachCleanup([bldr, loc, box]() {
                 fir::factory::genFinalization(*bldr, loc, box);
               });
             }
           },
           [](const auto &) {});
       return *allocatedResult;
     }
 
     if (!resultType)
       return mlir::Value{}; // subroutine call
     // For now, Fortran return values are implemented with a single MLIR
     // function return value.
-    assert(call.getNumResults() == 1 &&
+    assert(callNumResults == 1 &&
            "Expected exactly one result in FUNCTION call");
 
     // Call a BIND(C) function that return a char.
     if (caller.characterize().IsBindC() &&
         funcType.getResults()[0].isa<fir::CharacterType>()) {
       fir::CharacterType charTy =
           funcType.getResults()[0].dyn_cast<fir::CharacterType>();
       mlir::Value len = builder.createIntegerConstant(
           loc, builder.getCharacterLengthType(), charTy.getLen());
-      return fir::CharBoxValue{call.getResult(0), len};
+      return fir::CharBoxValue{callResult, len};
     }
 
-    return call.getResult(0);
+    return callResult;
   }
 
   /// Like genExtAddr, but ensure the address returned is a temporary even if \p
   /// expr is variable inside parentheses.
   ExtValue genTempExtAddr(const Fortran::lower::SomeExpr &expr) {
     // In general, genExtAddr might not create a temp for variable inside
     // parentheses to avoid creating array temporary in sub-expressions. It only
     // ensures the sub-expression is not re-associated with other parts of the
for (auto sub : llvm::enumerate(x.subscript())) {
               }},
           sub.value().u);
     }
     if (!useSlice)
       trips.clear();
   }
 
   static mlir::Type unwrapBoxEleTy(mlir::Type ty) {
-    if (auto boxTy = ty.dyn_cast<fir::BoxType>())
+    if (auto boxTy = ty.dyn_cast<fir::BaseBoxType>())
       return fir::unwrapRefType(boxTy.getEleTy());
     return ty;
   }
 
   llvm::SmallVector<mlir::Value> getShape(mlir::Type ty) {
     llvm::SmallVector<mlir::Value> result;
     ty = unwrapBoxEleTy(ty);
     mlir::Location loc = getLoc();
for (const auto &v : llvm::reverse(revPath)) {
                   ty = recTy.getType(name);
                   auto fld = builder.create<fir::FieldIndexOp>(
                       loc, fieldTy, name, recTy, fir::getTypeParams(arrayExv));
                   addComponentList(ty, {fld});
                   if (index != revPath.size() - 1 || !isPointerAssignment()) {
                     // Need an intermediate  dereference if the boxed value
                     // appears in the middle of the component path or if it is
                     // on the right and this is not a pointer assignment.
-                    if (auto boxTy = ty.dyn_cast<fir::BoxType>()) {
+                    if (auto boxTy = ty.dyn_cast<fir::BaseBoxType>()) {
                       auto currentFunc = components.getExtendCoorRef();
                       auto loc = getLoc();
                       auto *bldr = &converter.getFirOpBuilder();
                       auto newCoorRef = [=](mlir::Value val) -> mlir::Value {
                         return bldr->create<fir::LoadOp>(loc, currentFunc(val));
                       };
                       components.extendCoorRef = newCoorRef;
                       deref = true;
                     }
                   }
-                } else if (auto boxTy = ty.dyn_cast<fir::BoxType>()) {
+                } else if (auto boxTy = ty.dyn_cast<fir::BaseBoxType>()) {
                   ty = fir::unwrapRefType(boxTy.getEleTy());
                   auto recTy = ty.cast<fir::RecordType>();
                   ty = recTy.getType(name);
                   auto fld = builder.create<fir::FieldIndexOp>(
                       loc, fieldTy, name, recTy, fir::getTypeParams(arrayExv));
                   extendComponent(components, ty, {fld});
                 } else {
                   TODO(loc, "other component type");
if (isProjectedCopyInCopyOut()) {
               loc, builder.getRefType(eleBoxTy), innerArg, iters.iterVec(),
               fir::factory::getTypeParams(loc, builder, load));
           mlir::Value addr = components.getExtendCoorRef()(arrayOp);
           components.resetExtendCoorRef();
           // When the lhs is a boxed value and the context is not a pointer
           // assignment, then insert the dereference of the box before any
           // conversion and store.
           if (!isPointerAssignment()) {
-            if (auto boxTy = eleTy.dyn_cast<fir::BoxType>()) {
+            if (auto boxTy = eleTy.dyn_cast<fir::BaseBoxType>()) {
               eleTy = fir::boxMemRefType(boxTy);
               addr = builder.create<fir::BoxAddrOp>(loc, eleTy, addr);
               eleTy = fir::unwrapRefType(eleTy);
             }
           }
           auto ele = convertElementForUpdate(loc, eleTy, iters.getElement());
           builder.create<fir::StoreOp>(loc, ele, addr);
           auto amend = builder.create<fir::ArrayAmendOp>(

flang/lib/Lower/Mangler.cpp

return std::visit(
             return fir::NameUniquer::doCommonBlock(symbolName);
           },
           [&](const Fortran::semantics::DerivedTypeDetails &) -> std::string {
             // Derived type mangling must used mangleName(DerivedTypeSpec&) so
             // that kind type parameter values can be mangled.
             llvm::report_fatal_error(
                 "only derived type instances can be mangled");
           },
+          [&](const Fortran::semantics::ProcBindingDetails &procBinding)
+              -> std::string {
+            return mangleName(procBinding.symbol(), keepExternalInScope);
+          },
           [](const auto &) -> std::string { TODO_NOLOC("symbol mangling"); },
       },
       ultimateSymbol.details());
 }
 
 std::string Fortran::lower::mangle::mangleName(
     const Fortran::semantics::DerivedTypeSpec &derivedType) {
   // Resolve host and module association before mangling

flang/lib/Optimizer/Builder/BoxValue.cpp

if (nParams != 0)
       return false;
   }
   return true;
 }
 
 /// Debug verifier for BoxValue ctor. There is no guarantee this will
 /// always be called.
 bool fir::BoxValue::verify() const {
-  if (!addr.getType().isa<fir::BoxType>())
+  if (!addr.getType().isa<fir::BaseBoxType>())
     return false;
   if (!lbounds.empty() && lbounds.size() != rank())
     return false;
   // Explicit extents are here to cover cases where an explicit-shape dummy
   // argument comes as a fir.box. This can only happen with derived types and
   // unlimited polymorphic.
   if (!extents.empty() && !(isDerived() || isUnlimitedPolymorphic()))
     return false;

flang/lib/Optimizer/Builder/FIRBuilder.cpp

return exv.match(
         [&](auto) -> mlir::Value { fir::emitFatalError(loc, "not an array"); });
   }
   return create<fir::SliceOp>(loc, triples, path);
 }
 
 mlir::Value fir::FirOpBuilder::createBox(mlir::Location loc,
                                          const fir::ExtendedValue &exv) {
   mlir::Value itemAddr = fir::getBase(exv);
-  if (itemAddr.getType().isa<fir::BoxType>())
+  if (itemAddr.getType().isa<fir::BaseBoxType>())
     return itemAddr;
   auto elementType = fir::dyn_cast_ptrEleTy(itemAddr.getType());
   if (!elementType) {
     mlir::emitError(loc, "internal: expected a memory reference type ")
         << itemAddr.getType();
     llvm_unreachable("not a memory reference type");
   }
   mlir::Type boxTy = fir::BoxType::get(elementType);
   return exv.match(
       [&](const fir::ArrayBoxValue &box) -> mlir::Value {
         mlir::Value s = createShape(loc, exv);
         return create<fir::EmboxOp>(loc, boxTy, itemAddr, s);
       },
       [&](const fir::CharArrayBoxValue &box) -> mlir::Value {
         mlir::Value s = createShape(loc, exv);
         if (fir::factory::CharacterExprHelper::hasConstantLengthInType(exv))
           return create<fir::EmboxOp>(loc, boxTy, itemAddr, s);

 }
 
 // If valTy is a box type, then we need to extract the type parameters from
 // the box value.
 static llvm::SmallVector<mlir::Value> getFromBox(mlir::Location loc,
                                                  fir::FirOpBuilder &builder,
                                                  mlir::Type valTy,
                                                  mlir::Value boxVal) {
-  if (auto boxTy = valTy.dyn_cast<fir::BoxType>()) {
+  if (auto boxTy = valTy.dyn_cast<fir::BaseBoxType>()) {
     auto eleTy = fir::unwrapAllRefAndSeqType(boxTy.getEleTy());
     if (auto recTy = eleTy.dyn_cast<fir::RecordType>()) {
       if (recTy.getNumLenParams() > 0) {
         // Walk each type parameter in the record and get the value.
         TODO(loc, "generate code to get LEN type parameters");
       }
     } else if (auto charTy = eleTy.dyn_cast<fir::CharacterType>()) {
       if (charTy.hasDynamicLen()) {
return exv.match(
       [&](const fir::MutableBoxValue &box) { return handleBoxed(box); },
       [&](const auto &) { return fir::getTypeParams(exv); });
 }
 
 llvm::SmallVector<mlir::Value>
 fir::factory::getTypeParams(mlir::Location loc, fir::FirOpBuilder &builder,
                             fir::ArrayLoadOp load) {
   mlir::Type memTy = load.getMemref().getType();
-  if (auto boxTy = memTy.dyn_cast<fir::BoxType>())
+  if (auto boxTy = memTy.dyn_cast<fir::BaseBoxType>())
     return getFromBox(loc, builder, boxTy, load.getMemref());
   return load.getTypeparams();
 }
 
 std::string fir::factory::uniqueCGIdent(llvm::StringRef prefix,
                                         llvm::StringRef name) {
   // For "long" identifiers use a hash value
   if (name.size() > nameLengthHashSize) {

flang/lib/Optimizer/Dialect/FIROps.cpp

if ((isPointerCompatible(inType) && isPointerCompatible(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::isBoxedRecordType(inType) && fir::isPolymorphicType(outType)))
+      (fir::isBoxedRecordType(inType) && fir::isPolymorphicType(outType)) ||
+      (fir::isPolymorphicType(inType) && fir::isPolymorphicType(outType)))
     return mlir::success();
   return emitOpError("invalid type conversion");
 }
 
 //===----------------------------------------------------------------------===//
 // CoordinateOp
 //===----------------------------------------------------------------------===//
 

flang/test/Lower/dispatch.f90

+! RUN: bbc -polymorphic-type -emit-fir %s -o - | FileCheck %s
+
+! Tests the different possible type involving polymorphic entities.
+
+module call_dispatch
+
+  interface
+    subroutine nopass_defferred(x)
+      real :: x(:)
+    end subroutine
+  end interface
+
+  type p1
+    integer :: a
+    integer :: b
+  contains
+    procedure, nopass :: tbp_nopass
+    procedure :: tbp_pass
+    procedure, pass(this) :: tbp_pass_arg0
+    procedure, pass(this) :: tbp_pass_arg1
+
+    procedure, nopass :: proc1 => p1_proc1_nopass
+    procedure :: proc2 => p1_proc2
+    procedure, pass(this) :: proc3 => p1_proc3_arg0
+    procedure, pass(this) :: proc4 => p1_proc4_arg1
+
+    procedure, nopass :: p1_fct1_nopass
+    procedure :: p1_fct2
+    procedure, pass(this) :: p1_fct3_arg0
+    procedure, pass(this) :: p1_fct4_arg1
+  end type
+
+  type, abstract :: a1
+    real :: a
+    real :: b
+  contains
+    procedure(nopass_defferred), deferred, nopass :: nopassd
+  end type
+
+  contains
+
+! ------------------------------------------------------------------------------
+! Test lowering of type-bound procedure call on polymorphic entities
+! ------------------------------------------------------------------------------
+
+    function p1_fct1_nopass()
+      real :: p1_fct1_nopass
+    end function
+    ! CHECK-LABEL: func.func @_QMcall_dispatchPp1_fct1_nopass() -> f32
+
+    function p1_fct2(p)
+      real :: p1_fct2
+      class(p1) :: p
+    end function
+    ! CHECK-LABEL: func.func @_QMcall_dispatchPp1_fct2(%{{.*}}: !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>) -> f32
+
+    function p1_fct3_arg0(this)
+      real :: p1_fct2
+      class(p1) :: this
+    end function
+    ! CHECK-LABEL: func.func @_QMcall_dispatchPp1_fct3_arg0(%{{.*}}: !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>) -> f32
+
+    function p1_fct4_arg1(i, this)
+      real :: p1_fct2
+      integer :: i
+      class(p1) :: this
+    end function
+    ! CHECK-LABEL: func.func @_QMcall_dispatchPp1_fct4_arg1(%{{.*}}: !fir.ref<i32>, %{{.*}}: !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>) -> f32
+
+    subroutine p1_proc1_nopass()
+    end subroutine
+    ! CHECK-LABEL: func.func @_QMcall_dispatchPp1_proc1_nopass()
+
+    subroutine p1_proc2(p)
+      class(p1) :: p
+    end subroutine
+    ! CHECK-LABEL: func.func @_QMcall_dispatchPp1_proc2(%{{.*}}: !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>)
+
+    subroutine p1_proc3_arg0(this)
+      class(p1) :: this
+    end subroutine
+    ! CHECK-LABEL: func.func @_QMcall_dispatchPp1_proc3_arg0(%{{.*}}: !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>)
+
+    subroutine p1_proc4_arg1(i, this)
+      integer, intent(in) :: i
+      class(p1) :: this
+    end subroutine
+    ! CHECK-LABEL: func.func @_QMcall_dispatchPp1_proc4_arg1(%{{.*}}: !fir.ref<i32>, %{{.*}}: !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>)
+
+    subroutine tbp_nopass()
+    end subroutine
+    ! CHECK-LABEL: func.func @_QMcall_dispatchPtbp_nopass()
+
+    subroutine tbp_pass(t)
+      class(p1) :: t
+    end subroutine
+    ! CHECK-LABEL: func.func @_QMcall_dispatchPtbp_pass(%{{.*}}: !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>)
+
+    subroutine tbp_pass_arg0(this)
+      class(p1) :: this
+    end subroutine
+    ! CHECK-LABEL: func.func @_QMcall_dispatchPtbp_pass_arg0(%{{.*}}: !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>)
+
+    subroutine tbp_pass_arg1(i, this)
+      integer, intent(in) :: i
+      class(p1) :: this
+    end subroutine
+    ! CHECK-LABEL: func.func @_QMcall_dispatchPtbp_pass_arg1(%{{.*}}: !fir.ref<i32>, %{{.*}}: !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>)
+
+    subroutine check_dispatch(p)
+      class(p1) :: p
+      real :: a
+
+      call p%tbp_nopass()
+      call p%tbp_pass()
+      call p%tbp_pass_arg0()
+      call p%tbp_pass_arg1(1)
+
+      call p%proc1()
+      call p%proc2()
+      call p%proc3()
+      call p%proc4(1)
+
+      a = p%p1_fct1_nopass()
+      a = p%p1_fct2()
+      a = p%p1_fct3_arg0()
+      a = p%p1_fct4_arg1(1)
+    end subroutine
+
+! CHECK-LABEL: func.func @_QMcall_dispatchPcheck_dispatch(
+! CHECK-SAME:  %[[P:.*]]: !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>> {fir.bindc_name = "p"}) {
+! CHECK:       fir.dispatch "tbp_nopass"(%[[P]] : !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>){{$}}
+! CHECK:       fir.dispatch "tbp_pass"(%[[P]] : !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>) (%[[P]] : !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>) {pass_arg_pos = 0 : i32}
+! CHECK:       fir.dispatch "tbp_pass_arg0"(%[[P]] : !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>) (%[[P]] : !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>) {pass_arg_pos = 0 : i32}
+! CHECK:       fir.dispatch "tbp_pass_arg1"(%[[P]] : !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>)  (%{{.*}}, %[[P]] : !fir.ref<i32>, !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>) {pass_arg_pos = 1 : i32} 
+
+! CHECK:       fir.dispatch "proc1"(%[[P]] : !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>){{$}}
+! CHECK:       fir.dispatch "proc2"(%[[P]] : !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>) (%[[P]] : !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>) {pass_arg_pos = 0 : i32}
+! CHECK:       fir.dispatch "proc3"(%[[P]] : !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>) (%[[P]] : !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>) {pass_arg_pos = 0 : i32}
+! CHECK:       fir.dispatch "proc4"(%[[P]] : !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>) (%{{.*}}, %[[P]] : !fir.ref<i32>, !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>) {pass_arg_pos = 1 : i32}
+
+! CHECK: %{{.*}} = fir.dispatch "p1_fct1_nopass"(%[[P]] : !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>) -> f32{{$}}
+! CHECK: %{{.*}} = fir.dispatch "p1_fct2"(%[[P]] : !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>) (%[[P]] : !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>) -> f32 {pass_arg_pos = 0 : i32}
+! CHECK: %{{.*}} = fir.dispatch "p1_fct3_arg0"(%[[P]] : !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>) (%[[P]] : !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>) -> f32 {pass_arg_pos = 0 : i32}
+! CHECK: %{{.*}} = fir.dispatch "p1_fct4_arg1"(%[[P]] : !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>) (%{{.*}}, %[[P]] : !fir.ref<i32>, !fir.class<!fir.type<_QMcall_dispatchTp1{a:i32,b:i32}>>) -> f32 {pass_arg_pos = 1 : i32}
+
+  subroutine check_dispatch_deferred(a, x)
+    class(a1) :: a
+    real :: x(:)
+    call a%nopassd(x)
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMcall_dispatchPcheck_dispatch_deferred(
+! CHECK-SAME: %[[ARG0:.*]]: !fir.class<!fir.type<_QMcall_dispatchTa1{a:f32,b:f32}>> {fir.bindc_name = "a"}, 
+! CHECK-SAME: %[[ARG1:.*]]: !fir.box<!fir.array<?xf32>> {fir.bindc_name = "x"}) {
+! CHECK: fir.dispatch "nopassd"(%[[ARG0]] : !fir.class<!fir.type<_QMcall_dispatchTa1{a:f32,b:f32}>>) (%[[ARG1]] : !fir.box<!fir.array<?xf32>>)
+
+! ------------------------------------------------------------------------------
+! Test that direct call is emitted when the type is known
+! ------------------------------------------------------------------------------
+
+    subroutine check_nodispatch(t)
+      type(p1) :: t
+      call t%tbp_nopass()
+      call t%tbp_pass()
+      call t%tbp_pass_arg0()
+      call t%tbp_pass_arg1(1)
+    end subroutine
+
+! CHECK-LABEL: func.func @_QMcall_dispatchPcheck_nodispatch
+! CHECK: fir.call @_QMcall_dispatchPtbp_nopass
+! CHECK: fir.call @_QMcall_dispatchPtbp_pass
+! CHECK: fir.call @_QMcall_dispatchPtbp_pass_arg0
+! CHECK: fir.call @_QMcall_dispatchPtbp_pass_arg1
+
+end module