[flang] Create fir.dispatch_table and fir.dt_entry operations

[clementval]

Summary

Create the fir.dispatch_table operation based on semantics
information. The fir.dispatch_table will be used for static devirtualization
as well as for fir.select_type conversion.

Depends on D138129

[clementval]

clang-format

[PeteSteinfeld]

I had one nit, but otherwise all build and tests correctly and looks good.

flang/lib/Lower/Bridge.cpp

249

Should read "to generate the "

253

Did you mean to say "symbols symbols"?

flang/lib/Optimizer/Dialect/FIROps.cpp

1103

You can move this declaration closer to where parent is used.

[jeanPerier]

Looks great

flang/include/flang/Optimizer/Dialect/FIROps.td

2809

Why do you need both the sym_name and symref ? Can't the sym_name be deduced from the symref somehow ?

[clementval]

Fix after update to D138129

[clementval]

flang/include/flang/Optimizer/Dialect/FIROps.td

2809

I was following GlobalOp but might be unnecessary. I'll try to get rid of it.

[clementval]

Address review comment

[clementval]

flang/include/flang/Optimizer/Dialect/FIROps.td

2809

So this is actually doable if we use a SymbolNameAttr and the Printer API to print it correctly. We should update GlobalOp a some point to follow this as well instead of having two attributes.

flang/include/flang/Lower/AbstractConverter.h

public:
   /// Generate the type from a Variable
   virtual mlir::Type genType(const pft::Variable &) = 0;
 
   /// Register a runtime derived type information object symbol to ensure its
   /// object will be generated as a global.
   virtual void registerRuntimeTypeInfo(mlir::Location loc,
                                        SymbolRef typeInfoSym) = 0;
 
+  virtual void registerDispatchTableInfo(
+      mlir::Location loc,
+      const Fortran::semantics::DerivedTypeSpec *typeSpec) = 0;
+
   //===--------------------------------------------------------------------===//
   // Locations
   //===--------------------------------------------------------------------===//
 
   /// Get the converter's current location
   virtual mlir::Location getCurrentLocation() = 0;
   /// Generate a dummy location
   virtual mlir::Location genUnknownLocation() = 0;

flang/include/flang/Optimizer/Builder/FIRBuilder.h

public:
   createGlobalConstant(mlir::Location loc, mlir::Type type,
                        llvm::StringRef name,
                        std::function<void(FirOpBuilder &)> bodyBuilder,
                        mlir::StringAttr linkage = {}) {
     return createGlobal(loc, type, name, /*isConst=*/true, /*isTarget=*/false,
                         bodyBuilder, linkage);
   }
 
+  /// Create a fir::DispatchTable operation.
+  fir::DispatchTableOp createDispatchTableOp(mlir::Location loc,
+                                             llvm::StringRef name,
+                                             llvm::StringRef parentName);
+
   /// Convert a StringRef string into a fir::StringLitOp.
   fir::StringLitOp createStringLitOp(mlir::Location loc,
                                      llvm::StringRef string);
 
   //===--------------------------------------------------------------------===//
   // Linkage helpers (inline). The default linkage is external.
   //===--------------------------------------------------------------------===//
 

flang/include/flang/Optimizer/Dialect/FIROps.td

let description = [{
     ```mlir
       fir.dispatch_table @_QDTMquuzTfoo {
         fir.dt_entry method1, @_QFNMquuzTfooPmethod1AfooR
         fir.dt_entry method2, @_QFNMquuzTfooPmethod2AfooII
       }
     ```
   }];
 
+  let arguments = (ins
+    StrAttr:$sym_name,
+    SymbolRefAttr:$symref,
+    OptionalAttr<StrAttr>:$parent
+  );
+
   let hasCustomAssemblyFormat = 1;
   let hasVerifier = 1;
 
-  let regions = (region SizedRegion<1>:$region);
+  let regions = (region AnyRegion:$region);
 
   let skipDefaultBuilders = 1;
   let builders = [
     OpBuilder<(ins "llvm::StringRef":$name, "mlir::Type":$type,
-      CArg<"llvm::ArrayRef<mlir::NamedAttribute>", "{}">:$attrs),
-    [{
-      $_state.addAttribute(mlir::SymbolTable::getSymbolAttrName(),
-                           $_builder.getStringAttr(name));
-      $_state.addAttributes(attrs);
-    }]>
+      "llvm::StringRef":$parent,
+      CArg<"llvm::ArrayRef<mlir::NamedAttribute>", "{}">:$attrs)>
   ];
 
   let extraClassDeclaration = [{
     /// Append a dispatch table entry to the table.
     void appendTableEntry(mlir::Operation *op);
 
+    static constexpr llvm::StringRef getSymbolAttrNameStr() { return "symref"; }
+    static constexpr llvm::StringRef getParentAttrNameStr() { return "parent"; }
+    static constexpr llvm::StringRef getExtendsKeyword() { return "extends"; }
+
     mlir::Block &getBlock() {
       return getRegion().front();
     }
   }];
 }
 
 def fir_DTEntryOp : fir_Op<"dt_entry", [HasParent<"DispatchTableOp">]> {
   let summary = "map entry in a dispatch table";

flang/lib/Lower/Bridge.cpp

 #include "flang/Optimizer/Transforms/Passes.h"
 #include "flang/Parser/parse-tree.h"
 #include "flang/Runtime/iostat.h"
 #include "flang/Semantics/tools.h"
 #include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h"
 #include "mlir/IR/PatternMatch.h"
 #include "mlir/Parser/Parser.h"
 #include "mlir/Transforms/RegionUtils.h"
+#include "llvm/ADT/StringSet.h"
 #include "llvm/Support/CommandLine.h"
 #include "llvm/Support/Debug.h"
 #include "llvm/Support/ErrorHandling.h"
 
 #define DEBUG_TYPE "flang-lower-bridge"
 
 static llvm::cl::opt<bool> dumpBeforeFir(
     "fdebug-dump-pre-fir", llvm::cl::init(false),
private:
   /// symbol in registeredTypeInfoSymbols.
   bool skipRegistration = false;
   /// Track symbols symbols processed during and after the registration
   /// to avoid infinite loops between type conversions and global variable
   /// creation.
   llvm::SmallSetVector<Fortran::semantics::SymbolRef, 64> seen;
 };
 
+class DispatchTableConverter {
+  struct DispatchTableInfo {
+    const Fortran::semantics::DerivedTypeSpec *typeSpec;
+    mlir::Location loc;
+  };
+
+public:
+  void registerTypeSpec(mlir::Location loc,
+                        const Fortran::semantics::DerivedTypeSpec *typeSpec) {
+    assert(typeSpec && "type spec is null");
+    std::string dtName = Fortran::lower::mangle::mangleName(*typeSpec);
+    if (seen.contains(dtName) || dtName.find("__fortran") != std::string::npos)
+      return;
+    seen.insert(dtName);
+    registeredDispatchTableInfo.emplace_back(DispatchTableInfo{typeSpec, loc});
+  }
+
+  void createDispatchTableOps(Fortran::lower::AbstractConverter &converter) {
+    for (const DispatchTableInfo &info : registeredDispatchTableInfo) {
+      std::string dtName = Fortran::lower::mangle::mangleName(*info.typeSpec);
+      const Fortran::semantics::DerivedTypeSpec *parent =
+          Fortran::evaluate::GetParentTypeSpec(*info.typeSpec);
+      fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+      fir::DispatchTableOp dt = builder.createDispatchTableOp(
+          info.loc, dtName,
+          parent ? Fortran::lower::mangle::mangleName(*parent) : "");
+      auto insertPt = builder.saveInsertionPoint();
+
+      std::vector<const Fortran::semantics::Symbol *> bindings =
+          Fortran::semantics::CollectBindings(*info.typeSpec->scope());
+
+      if (!bindings.empty())
+        builder.createBlock(&dt.getRegion());
+
+      for (const Fortran::semantics::Symbol *binding : bindings) {
+        const auto *details =
+            binding->detailsIf<Fortran::semantics::ProcBindingDetails>();
+        std::string bindingName =
+            Fortran::lower::mangle::mangleName(details->symbol());
+        builder.create<fir::DTEntryOp>(
+            info.loc,
+            mlir::StringAttr::get(builder.getContext(),
+                                  binding->name().ToString()),
+            mlir::SymbolRefAttr::get(builder.getContext(), bindingName));
+      }
+      if (!bindings.empty())
+        builder.create<fir::FirEndOp>(info.loc);
+      builder.restoreInsertionPoint(insertPt);
+    }
+    registeredDispatchTableInfo.clear();
+  }
+
+private:
+  /// Store the semantic DerivedTypeSpec that will be required to generated the
+  /// dispatch table.
+  llvm::SmallVector<DispatchTableInfo> registeredDispatchTableInfo;
+
+  /// Track symbols symbols processed during and after the registration
+  /// to avoid infinite loops between type conversions and global variable
+  /// creation.
+  llvm::StringSet<> seen;
+};
+
 using IncrementLoopNestInfo = llvm::SmallVector<IncrementLoopInfo, 8>;
 } // namespace
 
 //===----------------------------------------------------------------------===//
 // FirConverter
 //===----------------------------------------------------------------------===//
 
 namespace {
void run(Fortran::lower::pft::Program &pft) {
     }
 
     /// Once all the code has been translated, create runtime type info
     /// global data structure for the derived types that have been
     /// processed.
     createGlobalOutsideOfFunctionLowering(
         [&]() { runtimeTypeInfoConverter.createTypeInfoGlobals(*this); });
 
+    /// Create the dispatch tables for derived types.
+    createGlobalOutsideOfFunctionLowering(
+        [&]() { dispatchTableConverter.createDispatchTableOps(*this); });
+
     // Create the list of any environment defaults for the runtime to set. The
     // runtime default list is only created if there is a main program to ensure
     // it only happens once and to provide consistent results if multiple files
     // are compiled separately.
     if (hasMainProgram)
       createGlobalOutsideOfFunctionLowering([&]() {
         // FIXME: Ideally, this would create a call to a runtime function
         // accepting the list of environment defaults. That way, we would not
public:
   }
 
   void registerRuntimeTypeInfo(
       mlir::Location loc,
       Fortran::lower::SymbolRef typeInfoSym) override final {
     runtimeTypeInfoConverter.registerTypeInfoSymbol(*this, loc, typeInfoSym);
   }
 
+  void registerDispatchTableInfo(
+      mlir::Location loc,
+      const Fortran::semantics::DerivedTypeSpec *typeSpec) override final {
+    dispatchTableConverter.registerTypeSpec(loc, typeSpec);
+  }
+
 private:
   FirConverter() = delete;
   FirConverter(const FirConverter &) = delete;
   FirConverter &operator=(const FirConverter &) = delete;
 
   //===--------------------------------------------------------------------===//
   // Helper member functions
   //===--------------------------------------------------------------------===//

 
   Fortran::lower::LoweringBridge &bridge;
   Fortran::evaluate::FoldingContext foldingContext;
   fir::FirOpBuilder *builder = nullptr;
   Fortran::lower::pft::Evaluation *evalPtr = nullptr;
   Fortran::lower::SymMap localSymbols;
   Fortran::parser::CharBlock currentPosition;
   RuntimeTypeInfoConverter runtimeTypeInfoConverter;
+  DispatchTableConverter dispatchTableConverter;
 
   /// WHERE statement/construct mask expression stack.
   Fortran::lower::ImplicitIterSpace implicitIterSpace;
 
   /// FORALL context
   Fortran::lower::ExplicitIterSpace explicitIterSpace;
 
   /// Tuple of host assoicated variables.

flang/lib/Lower/ConvertType.cpp

mlir::Type genDerivedType(const Fortran::semantics::DerivedTypeSpec &tySpec) {
     mlir::Location loc = converter.genLocation(typeSymbol.name());
     if (!ps.empty()) {
       // This type is a PDT (parametric derived type). Create the functions to
       // use for allocation, dereferencing, and address arithmetic here.
       TODO(loc, "parameterized derived types");
     }
     LLVM_DEBUG(llvm::dbgs() << "derived type: " << rec << '\n');
 
+    converter.registerDispatchTableInfo(loc, &tySpec);
+
     // Generate the type descriptor object if any
     if (const Fortran::semantics::Scope *derivedScope =
             tySpec.scope() ? tySpec.scope() : tySpec.typeSymbol().scope())
       if (const Fortran::semantics::Symbol *typeInfoSym =
               derivedScope->runtimeDerivedTypeDescription())
         converter.registerRuntimeTypeInfo(loc, *typeInfoSym);
     return rec;
   }

flang/lib/Optimizer/Builder/FIRBuilder.cpp

fir::GlobalOp fir::FirOpBuilder::createGlobal(
   region.push_back(new mlir::Block);
   auto &block = glob.getRegion().back();
   setInsertionPointToStart(&block);
   bodyBuilder(*this);
   restoreInsertionPoint(insertPt);
   return glob;
 }
 
+fir::DispatchTableOp fir::FirOpBuilder::createDispatchTableOp(
+    mlir::Location loc, llvm::StringRef name, llvm::StringRef parentName) {
+  auto module = getModule();
+  auto insertPt = saveInsertionPoint();
+  if (auto dt = module.lookupSymbol<fir::DispatchTableOp>(name))
+    return dt;
+  setInsertionPoint(module.getBody(), module.getBody()->end());
+  auto dt = create<fir::DispatchTableOp>(loc, name, mlir::Type{}, parentName);
+  restoreInsertionPoint(insertPt);
+  return dt;
+}
+
 mlir::Value
 fir::FirOpBuilder::convertWithSemantics(mlir::Location loc, mlir::Type toTy,
                                         mlir::Value val,
                                         bool allowCharacterConversion) {
   assert(toTy && "store location must be typed");
   auto fromTy = val.getType();
   if (fromTy == toTy)
     return val;

flang/lib/Optimizer/CodeGen/CodeGen.cpp

auto callOp = rewriter.replaceOpWithNewOp<mlir::LLVM::CallOp>(
                                       : fctType.getReturnType(),
         "", args);
     callOp.removeCalleeAttr(); // Indirect calls do not have callee attr.
 
     return mlir::success();
   }
 };
 
-/// Lower `fir.dispatch_table` operation. The dispatch table for a Fortran
-/// derived type.
+/// `fir.disptach_table` operation has no specific CodeGen. The operation is
+/// only used to carry information during FIR to FIR passes.
 struct DispatchTableOpConversion
     : public FIROpConversion<fir::DispatchTableOp> {
   using FIROpConversion::FIROpConversion;
 
   mlir::LogicalResult
-  matchAndRewrite(fir::DispatchTableOp dispTab, OpAdaptor adaptor,
+  matchAndRewrite(fir::DispatchTableOp op, OpAdaptor,
                   mlir::ConversionPatternRewriter &rewriter) const override {
-    TODO(dispTab.getLoc(), "fir.dispatch_table codegen");
-    return mlir::failure();
+    rewriter.eraseOp(op);
+    return mlir::success();
   }
 };
 
-/// Lower `fir.dt_entry` operation. An entry in a dispatch table; binds a
-/// method-name to a function.
+/// `fir.dt_entry` operation has no specific CodeGen. The operation is only used
+/// to carry information during FIR to FIR passes.
 struct DTEntryOpConversion : public FIROpConversion<fir::DTEntryOp> {
   using FIROpConversion::FIROpConversion;
 
   mlir::LogicalResult
-  matchAndRewrite(fir::DTEntryOp dtEnt, OpAdaptor adaptor,
+  matchAndRewrite(fir::DTEntryOp op, OpAdaptor,
                   mlir::ConversionPatternRewriter &rewriter) const override {
-    TODO(dtEnt.getLoc(), "fir.dt_entry codegen");
-    return mlir::failure();
+    rewriter.eraseOp(op);
+    return mlir::success();
   }
 };
 
 /// Lower `fir.global_len` operation.
 struct GlobalLenOpConversion : public FIROpConversion<fir::GlobalLenOp> {
   using FIROpConversion::FIROpConversion;
 
   mlir::LogicalResult

flang/lib/Optimizer/Dialect/FIROps.cpp

void fir::DispatchTableOp::appendTableEntry(mlir::Operation *op) {
   auto &block = getBlock();
   block.getOperations().insert(block.end(), op);
 }
 
 mlir::ParseResult fir::DispatchTableOp::parse(mlir::OpAsmParser &parser,
                                               mlir::OperationState &result) {
   // Parse the name as a symbol reference attribute.
   mlir::SymbolRefAttr nameAttr;
-  if (parser.parseAttribute(nameAttr, mlir::SymbolTable::getSymbolAttrName(),
+  if (parser.parseAttribute(nameAttr,
+                            fir::DispatchTableOp::getSymbolAttrNameStr(),
                             result.attributes))
     return mlir::failure();
-
-  // Convert the parsed name attr into a string attr.
-  result.attributes.set(mlir::SymbolTable::getSymbolAttrName(),
-                        nameAttr.getRootReference());
+  result.addAttribute(mlir::SymbolTable::getSymbolAttrName(),
 
+  mlir::StringAttr parent;
+  if (!failed(parser.parseOptionalKeyword(getExtendsKeyword()))) {
+    if (parser.parseLParen() ||
+        parser.parseAttribute(parent, getParentAttrNameStr(),
+                              result.attributes) ||
+        parser.parseRParen())
+      return mlir::failure();
+  }
+
   // Parse the optional table body.
   mlir::Region *body = result.addRegion();
   mlir::OptionalParseResult parseResult = parser.parseOptionalRegion(*body);
   if (parseResult.has_value() && failed(*parseResult))
     return mlir::failure();
 
   fir::DispatchTableOp::ensureTerminator(*body, parser.getBuilder(),
                                          result.location);
   return mlir::success();
 }
 
 void fir::DispatchTableOp::print(mlir::OpAsmPrinter &p) {
-  auto tableName = getOperation()
-                       ->getAttrOfType<mlir::StringAttr>(
-                           mlir::SymbolTable::getSymbolAttrName())
-                       .getValue();
-  p << " @" << tableName;
+  p << " " << getSymref();
+  if (getParent())
+    p << " " << getExtendsKeyword() << "("
+      << (*this)->getAttr(getParentAttrNameStr()) << ")";
 
   mlir::Region &body = getOperation()->getRegion(0);
   if (!body.empty()) {
     p << ' ';
     p.printRegion(body, /*printEntryBlockArgs=*/false,
                   /*printBlockTerminators=*/false);
   }
 }
 
 mlir::LogicalResult fir::DispatchTableOp::verify() {
-  for (auto &op : getBlock())
-    if (!mlir::isa<fir::DTEntryOp, fir::FirEndOp>(op))
-      return op.emitOpError("dispatch table must contain dt_entry");
+  // for (auto &op : getBlock())
+  //   if (!mlir::isa<fir::DTEntryOp, fir::FirEndOp>(op))
+  //     return op.emitOpError("dispatch table must contain dt_entry");
   return mlir::success();
 }
 
+void fir::DispatchTableOp::build(mlir::OpBuilder &builder,
+                                 mlir::OperationState &result,
+                                 llvm::StringRef name, mlir::Type type,
+                                 llvm::StringRef parent,
+                                 llvm::ArrayRef<mlir::NamedAttribute> attrs) {
+  result.addRegion();
+  result.addAttribute(mlir::SymbolTable::getSymbolAttrName(),
+                      builder.getStringAttr(name));
+  if (!parent.empty())
+    result.addAttribute(getParentAttrNameStr(), builder.getStringAttr(parent));
+  result.addAttribute(getSymbolAttrNameStr(),
+                      mlir::SymbolRefAttr::get(builder.getContext(), name));
+  result.addAttributes(attrs);
+}
+
 //===----------------------------------------------------------------------===//
 // EmboxOp
 //===----------------------------------------------------------------------===//
 
 mlir::LogicalResult fir::EmboxOp::verify() {
   auto eleTy = fir::dyn_cast_ptrEleTy(getMemref().getType());
   bool isArray = false;
   if (auto seqTy = eleTy.dyn_cast<fir::SequenceType>()) {

flang/test/Fir/Todo/dispatch_table.fir

-// RUN: %not_todo_cmd fir-opt --fir-to-llvm-ir="target=x86_64-unknown-linux-gnu" %s 2>&1 | FileCheck %s
-
-// Test fir.dispatch_table conversion to llvm.
-// Not implemented yet.
-
-// CHECK: not yet implemented: fir.dispatch_table codegen
-fir.dispatch_table @dispatch_tbl {
-  fir.dt_entry "method", @method_impl
-}

flang/test/Lower/dispatch-table.f90

+! RUN: bbc -polymorphic-type -emit-fir %s -o - | FileCheck %s
+
+! Tests the generation of fir.dispatch_table operations.
+
+module polymorphic_types
+  type p1
+    integer :: a
+    integer :: b
+  contains
+    procedure :: proc1 => proc1_p1
+    procedure :: aproc
+    procedure :: zproc
+  end type
+
+  type, extends(p1) :: p2
+    integer :: c
+  contains
+    procedure :: proc1 => proc1_p2
+    procedure :: aproc2
+  end type
+
+  type, extends(p2) :: p3
+    integer :: d
+  contains
+    procedure :: aproc3
+  end type
+contains
+
+
+  subroutine proc1_p1(p)
+    class(p1) :: p
+  end subroutine
+
+  subroutine aproc(p)
+    class(p1) :: p
+  end subroutine
+
+  subroutine zproc(p)
+    class(p1) :: p
+  end subroutine
+
+  subroutine proc1_p2(p)
+    class(p2) :: p
+  end subroutine
+
+  subroutine aproc2(p)
+    class(p2) :: p
+  end subroutine
+
+  subroutine aproc3(p)
+    class(p3) :: p
+  end subroutine
+
+end module
+
+! CHECK-LABEL: fir.dispatch_table @_QMpolymorphic_typesTp1 {
+! CHECK:         fir.dt_entry "aproc", @_QMpolymorphic_typesPaproc
+! CHECK:         fir.dt_entry "proc1", @_QMpolymorphic_typesPproc1_p1
+! CHECK:         fir.dt_entry "zproc", @_QMpolymorphic_typesPzproc
+! CHECK:       }
+
+! CHECK-LABEL: fir.dispatch_table @_QMpolymorphic_typesTp2 extends("_QMpolymorphic_typesTp1") {
+! CHECK:         fir.dt_entry "aproc", @_QMpolymorphic_typesPaproc
+! CHECK:         fir.dt_entry "proc1", @_QMpolymorphic_typesPproc1_p2
+! CHECK:         fir.dt_entry "zproc", @_QMpolymorphic_typesPzproc
+! CHECK:         fir.dt_entry "aproc2", @_QMpolymorphic_typesPaproc2
+! CHECK:       }
+
+! CHECK-LABEL: fir.dispatch_table @_QMpolymorphic_typesTp3 extends("_QMpolymorphic_typesTp2") {
+! CHECK:         fir.dt_entry "aproc", @_QMpolymorphic_typesPaproc
+! CHECK:         fir.dt_entry "proc1", @_QMpolymorphic_typesPproc1_p2
+! CHECK:         fir.dt_entry "zproc", @_QMpolymorphic_typesPzproc
+! CHECK:         fir.dt_entry "aproc2", @_QMpolymorphic_typesPaproc2
+! CHECK:         fir.dt_entry "aproc3", @_QMpolymorphic_typesPaproc3
+! CHECK:       }

flang/test/Lower/polymorphic-types.f90

! ------------------------------------------------------------------------------
   ! CHECK-SAME: %{{.*}}: !fir.box<none>
 
   subroutine assumed_type_dummy_array(a) bind(c)
     type(*) :: a(:)
   end subroutine assumed_type_dummy_array
 
   ! CHECK-LABEL: func.func @assumed_type_dummy_array(
   ! CHECK-SAME: %{{.*}}: !fir.box<!fir.array<?xnone>>
+
 end module