[flang] Lower procedure pointer components

flang/include/flang/Lower/AbstractConverter.h

@@ -58,6 +58,8 @@ struct Variable;
 
 using SomeExpr = Fortran::evaluate::Expr<Fortran::evaluate::SomeType>;
 using SymbolRef = Fortran::common::Reference<const Fortran::semantics::Symbol>;
+using TypeConstructionStack =
+    llvm::SmallVector<std::pair<const Fortran::lower::SymbolRef, mlir::Type>>;
 class StatementContext;
 
 using ExprToValueMap = llvm::DenseMap<const SomeExpr *, mlir::Value>;
@@ -231,6 +233,10 @@ class AbstractConverter {
                    const Fortran::semantics::DerivedTypeSpec &typeSpec,
                    fir::RecordType type) = 0;
 
+  /// Get stack of derived type in construction. This is an internal entry point
+  /// for the type conversion utility to allow lowering recursive derived types.
+  virtual TypeConstructionStack &getTypeConstructionStack() = 0;
+
   //===--------------------------------------------------------------------===//
   // Locations
   //===--------------------------------------------------------------------===//

flang/include/flang/Lower/CallInterface.h

@@ -303,6 +303,11 @@ class CallerInterface : public CallInterface<CallerInterface> {
   /// index.
   std::optional<unsigned> getPassArgIndex() const;
 
+  /// Get the passed-object if any. Crashes if there is a passed object
+  /// but it was not placed in the inputs yet. Return a null value
+  /// otherwise.
+  mlir::Value getIfPassedArg() const;
+
   /// Return the procedure symbol if this is a call to a user defined
   /// procedure.
   const Fortran::semantics::Symbol *getProcedureSymbol() const;
@@ -314,8 +319,8 @@ class CallerInterface : public CallInterface<CallerInterface> {
                                   mlir::Value addr, mlir::Value len);
 
   /// If this is a call to a procedure pointer or dummy, returns the related
-  /// symbol. Nullptr otherwise.
-  const Fortran::semantics::Symbol *getIfIndirectCallSymbol() const;
+  /// procedure designator. Nullptr otherwise.
+  const Fortran::evaluate::ProcedureDesignator *getIfIndirectCall() const;
 
   /// Get the input vector once it is complete.
   llvm::ArrayRef<mlir::Value> getInputs() const {

flang/include/flang/Lower/ConvertProcedureDesignator.h

@@ -60,5 +60,13 @@ mlir::Value
 convertProcedureDesignatorInitialTarget(Fortran::lower::AbstractConverter &,
                                         mlir::Location,
                                         const Fortran::semantics::Symbol &sym);
+
+/// Given the value of a "PASS" actual argument \p passedArg and the
+/// evaluate::ProcedureDesignator for the call, address and dereference
+/// the argument's procedure pointer component that must be called.
+mlir::Value derefPassProcPointerComponent(
+    mlir::Location loc, Fortran::lower::AbstractConverter &converter,
+    const Fortran::evaluate::ProcedureDesignator &proc, mlir::Value passedArg,
+    Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx);
 } // namespace Fortran::lower
 #endif // FORTRAN_LOWER_CONVERT_PROCEDURE_DESIGNATOR_H

flang/include/flang/Optimizer/Support/InternalNames.h

@@ -156,6 +156,14 @@ struct NameUniquer {
   static std::string
   getTypeDescriptorBindingTableName(llvm::StringRef mangledTypeName);
 
+  /// Remove markers that have been added when doing partial type
+  /// conversions. mlir::Type cannot be mutated in a pass, so new
+  /// fir::RecordType must be created when lowering member types.
+  /// Suffixes added to these new types are meaningless and are
+  /// dropped in the names passed to LLVM.
+  static llvm::StringRef
+  dropTypeConversionMarkers(llvm::StringRef mangledTypeName);
+
 private:
   static std::string intAsString(std::int64_t i);
   static std::string doKind(std::int64_t kind);

flang/lib/Lower/Bridge.cpp

@@ -170,25 +170,22 @@ class TypeInfoConverter {
     if (seen.contains(typeInfoSym))
       return;
     seen.insert(typeInfoSym);
-    if (!skipRegistration) {
-      registeredTypeInfo.emplace_back(
-          TypeInfo{typeInfoSym, typeSpec, type, loc});
-      return;
-    }
-    // Once the registration is closed, symbols cannot be added to the
-    // registeredTypeInfoSymbols list because it may be iterated over.
-    // However, after registration is closed, it is safe to directly generate
-    // the globals because all FuncOps whose addresses may be required by the
-    // initializers have been generated.
-    createTypeInfoOpAndGlobal(converter,
-                              TypeInfo{typeInfoSym, typeSpec, type, loc});
+    currentTypeInfoStack->emplace_back(
+        TypeInfo{typeInfoSym, typeSpec, type, loc});
+    return;
   }
 
   void createTypeInfo(Fortran::lower::AbstractConverter &converter) {
-    skipRegistration = true;
-    for (const TypeInfo &info : registeredTypeInfo)
-      createTypeInfoOpAndGlobal(converter, info);
-    registeredTypeInfo.clear();
+    while (!registeredTypeInfoA.empty()) {
+      currentTypeInfoStack = &registeredTypeInfoB;
+      for (const TypeInfo &info : registeredTypeInfoA)
+        createTypeInfoOpAndGlobal(converter, info);
+      registeredTypeInfoA.clear();
+      currentTypeInfoStack = &registeredTypeInfoA;
+      for (const TypeInfo &info : registeredTypeInfoB)
+        createTypeInfoOpAndGlobal(converter, info);
+      registeredTypeInfoB.clear();
+    }
   }
 
 private:
@@ -249,11 +246,12 @@ class TypeInfoConverter {
   }
 
   /// Store the front-end data that will be required to generate the type info
-  /// for the derived types that have been converted to fir.type<>.
-  llvm::SmallVector<TypeInfo> registeredTypeInfo;
-  /// Create derived type info immediately without storing the
-  /// symbol in registeredTypeInfo.
-  bool skipRegistration = false;
+  /// for the derived types that have been converted to fir.type<>. There are
+  /// two stacks since the type info may visit new types, so the new types must
+  /// be added to a new stack.
+  llvm::SmallVector<TypeInfo> registeredTypeInfoA;
+  llvm::SmallVector<TypeInfo> registeredTypeInfoB;
+  llvm::SmallVector<TypeInfo> *currentTypeInfoStack = &registeredTypeInfoA;
   /// Track symbols symbols processed during and after the registration
   /// to avoid infinite loops between type conversions and global variable
   /// creation.
@@ -602,6 +600,11 @@ class FirConverter : public Fortran::lower::AbstractConverter {
         std::nullopt);
   }
 
+  Fortran::lower::TypeConstructionStack &
+  getTypeConstructionStack() override final {
+    return typeConstructionStack;
+  }
+
   bool isPresentShallowLookup(Fortran::semantics::Symbol &sym) override final {
     return bool(shallowLookupSymbol(sym));
   }
@@ -5008,6 +5011,13 @@ class FirConverter : public Fortran::lower::AbstractConverter {
   bool ompDeviceCodeFound = false;
 
   const Fortran::lower::ExprToValueMap *exprValueOverrides{nullptr};
+
+  /// Stack of derived type under construction to avoid infinite loops when
+  /// dealing with recursive derived types. This is held in the bridge because
+  /// the state needs to be maintained between data and function type lowering
+  /// utilities to deal with procedure pointer components whose arguments have
+  /// the type of the containing derived type.
+  Fortran::lower::TypeConstructionStack typeConstructionStack;
 };
 
 } // namespace

flang/lib/Lower/CallInterface.cpp

@@ -87,6 +87,11 @@ bool Fortran::lower::CallerInterface::isIndirectCall() const {
 }
 
 bool Fortran::lower::CallerInterface::requireDispatchCall() const {
+  // Procedure pointer component reference do not require dispatch, but
+  // have PASS/NOPASS argument.
+  if (const Fortran::semantics::Symbol *sym = procRef.proc().GetSymbol())
+    if (Fortran::semantics::IsPointer(*sym))
+      return false;
   // calls with NOPASS attribute still have their component so check if it is
   // polymorphic.
   if (const Fortran::evaluate::Component *component =
@@ -127,12 +132,21 @@ Fortran::lower::CallerInterface::getPassArgIndex() const {
   return passArg;
 }
 
-const Fortran::semantics::Symbol *
-Fortran::lower::CallerInterface::getIfIndirectCallSymbol() const {
+mlir::Value Fortran::lower::CallerInterface::getIfPassedArg() const {
+  if (std::optional<unsigned> passArg = getPassArgIndex()) {
+    assert(actualInputs.size() > *passArg && actualInputs[*passArg] &&
+           "passed arg was not set yet");
+    return actualInputs[*passArg];
+  }
+  return {};
+}
+
+const Fortran::evaluate::ProcedureDesignator *
+Fortran::lower::CallerInterface::getIfIndirectCall() const {
   if (const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol())
     if (Fortran::semantics::IsPointer(*symbol) ||
         Fortran::semantics::IsDummy(*symbol))
-      return symbol;
+      return &procRef.proc();
   return nullptr;
 }
 

flang/lib/Lower/ConvertCall.cpp

@@ -13,6 +13,7 @@
 #include "flang/Lower/ConvertCall.h"
 #include "flang/Lower/Allocatable.h"
 #include "flang/Lower/ConvertExprToHLFIR.h"
+#include "flang/Lower/ConvertProcedureDesignator.h"
 #include "flang/Lower/ConvertVariable.h"
 #include "flang/Lower/CustomIntrinsicCall.h"
 #include "flang/Lower/HlfirIntrinsics.h"
@@ -165,20 +166,28 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
   // will be used only if there is no explicit length in the local interface).
   mlir::Value funcPointer;
   mlir::Value charFuncPointerLength;
-  if (const Fortran::semantics::Symbol *sym =
-          caller.getIfIndirectCallSymbol()) {
-    funcPointer = fir::getBase(converter.getSymbolExtendedValue(*sym, &symMap));
-    if (!funcPointer)
-      fir::emitFatalError(loc, "failed to find indirect call symbol address");
-    if (fir::isCharacterProcedureTuple(funcPointer.getType(),
-                                       /*acceptRawFunc=*/false))
-      std::tie(funcPointer, charFuncPointerLength) =
-          fir::factory::extractCharacterProcedureTuple(builder, loc,
-                                                       funcPointer);
-    // Reference to a procedure pointer. Load its value, the address of the
-    // procedure it points to.
-    if (Fortran::semantics::IsProcedurePointer(sym))
-      funcPointer = builder.create<fir::LoadOp>(loc, funcPointer);
+  if (const Fortran::evaluate::ProcedureDesignator *procDesignator =
+          caller.getIfIndirectCall()) {
+    if (mlir::Value passedArg = caller.getIfPassedArg()) {
+      // Procedure pointer component call with PASS argument. To avoid
+      // "double" lowering of the ComponentRef, semantics only place the
+      // ComponentRef in the ActualArguments, not in the ProcedureDesignator (
+      // that is only the component symbol).
+      // Fetch the passed argument and addresses of its procedure pointer
+      // component.
+      funcPointer = Fortran::lower::derefPassProcPointerComponent(
+          loc, converter, *procDesignator, passedArg, symMap, stmtCtx);
+    } else {
+      Fortran::lower::SomeExpr expr{*procDesignator};
+      fir::ExtendedValue loweredProc =
+          converter.genExprAddr(loc, expr, stmtCtx);
+      funcPointer = fir::getBase(loweredProc);
+      // Dummy procedure may have assumed length, in which case the result
+      // length was passed along the dummy procedure.
+      // This is not possible with procedure pointer components.
+      if (const fir::CharBoxValue *charBox = loweredProc.getCharBox())
+        charFuncPointerLength = charBox->getLen();
+    }
   }
 
   mlir::IndexType idxTy = builder.getIndexType();

flang/lib/Lower/ConvertConstant.cpp

@@ -366,6 +366,8 @@ static mlir::Value genStructureComponentInit(
     TODO(loc, "allocatable component in structure constructor");
 
   if (Fortran::semantics::IsPointer(sym)) {
+    if (Fortran::semantics::IsProcedure(sym))
+      TODO(loc, "procedure pointer component initial value");
     mlir::Value initialTarget =
         Fortran::lower::genInitialDataTarget(converter, loc, componentTy, expr);
     res = builder.create<fir::InsertValueOp>(

flang/lib/Lower/ConvertExpr.cpp

@@ -4849,7 +4849,7 @@ class ArrayExprLowering {
       }
     }
 
-    if (caller.getIfIndirectCallSymbol())
+    if (caller.getIfIndirectCall())
       fir::emitFatalError(loc, "cannot be indirect call");
 
     // The lambda is mutable so that `caller` copy can be modified inside it.

flang/lib/Lower/ConvertExprToHLFIR.cpp

@@ -1738,6 +1738,8 @@ class HlfirBuilder {
 
       if (attrs && bitEnumContainsAny(attrs.getFlags(),
                                       fir::FortranVariableFlagsEnum::pointer)) {
+        if (Fortran::semantics::IsProcedure(sym))
+          TODO(loc, "procedure pointer component in structure constructor");
         // Pointer component construction is just a copy of the box contents.
         fir::ExtendedValue lhsExv =
             hlfir::translateToExtendedValue(loc, builder, lhs);

flang/lib/Lower/ConvertProcedureDesignator.cpp

@@ -19,6 +19,7 @@
 #include "flang/Optimizer/Builder/IntrinsicCall.h"
 #include "flang/Optimizer/Builder/Todo.h"
 #include "flang/Optimizer/Dialect/FIROps.h"
+#include "flang/Optimizer/HLFIR/HLFIROps.h"
 
 static bool areAllSymbolsInExprMapped(const Fortran::evaluate::ExtentExpr &expr,
                                       Fortran::lower::SymMap &symMap) {
@@ -96,6 +97,49 @@ fir::ExtendedValue Fortran::lower::convertProcedureDesignator(
   return funcPtr;
 }
 
+static hlfir::EntityWithAttributes designateProcedurePointerComponent(
+    mlir::Location loc, Fortran::lower::AbstractConverter &converter,
+    const Fortran::evaluate::Symbol &procComponentSym, mlir::Value base,
+    Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
+  fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+  fir::FortranVariableFlagsAttr attributes =
+      Fortran::lower::translateSymbolAttributes(builder.getContext(),
+                                                procComponentSym);
+  /// Passed argument may be a descriptor. This is a scalar reference, so the
+  /// base address can be directly addressed.
+  if (base.getType().isa<fir::BaseBoxType>())
+    base = builder.create<fir::BoxAddrOp>(loc, base);
+  std::string fieldName = converter.getRecordTypeFieldName(procComponentSym);
+  auto recordType =
+      hlfir::getFortranElementType(base.getType()).cast<fir::RecordType>();
+  mlir::Type fieldType = recordType.getType(fieldName);
+  // FIXME: semantics is not expanding intermediate parent components in:
+  // call x%p() where p is a component of a parent type of x type.
+  if (!fieldType)
+    TODO(loc, "reference to procedure pointer component from parent type");
+  mlir::Type designatorType = fir::ReferenceType::get(fieldType);
+  mlir::Value compRef = builder.create<hlfir::DesignateOp>(
+      loc, designatorType, base, fieldName,
+      /*compShape=*/mlir::Value{}, hlfir::DesignateOp::Subscripts{},
+      /*substring=*/mlir::ValueRange{},
+      /*complexPart=*/std::nullopt,
+      /*shape=*/mlir::Value{}, /*typeParams=*/mlir::ValueRange{}, attributes);
+  return hlfir::EntityWithAttributes{compRef};
+}
+
+static hlfir::EntityWithAttributes convertProcedurePointerComponent(
+    mlir::Location loc, Fortran::lower::AbstractConverter &converter,
+    const Fortran::evaluate::Component &procComponent,
+    Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
+  fir::ExtendedValue baseExv = Fortran::lower::convertDataRefToValue(
+      loc, converter, procComponent.base(), symMap, stmtCtx);
+  mlir::Value base = fir::getBase(baseExv);
+  const Fortran::semantics::Symbol &procComponentSym =
+      procComponent.GetLastSymbol();
+  return designateProcedurePointerComponent(loc, converter, procComponentSym,
+                                            base, symMap, stmtCtx);
+}
+
 hlfir::EntityWithAttributes Fortran::lower::convertProcedureDesignatorToHLFIR(
     mlir::Location loc, Fortran::lower::AbstractConverter &converter,
     const Fortran::evaluate::ProcedureDesignator &proc,
@@ -109,6 +153,10 @@ hlfir::EntityWithAttributes Fortran::lower::convertProcedureDesignatorToHLFIR(
       return *varDef;
   }
 
+  if (const Fortran::evaluate::Component *procComponent = proc.GetComponent())
+    return convertProcedurePointerComponent(loc, converter, *procComponent,
+                                            symMap, stmtCtx);
+
   fir::ExtendedValue procExv =
       convertProcedureDesignator(loc, converter, proc, symMap, stmtCtx);
   // Directly package the procedure address as a fir.boxproc or
@@ -148,3 +196,15 @@ mlir::Value Fortran::lower::convertProcedureDesignatorInitialTarget(
   return fir::getBase(Fortran::lower::convertToAddress(
       loc, converter, procVal, stmtCtx, procVal.getType()));
 }
+
+mlir::Value Fortran::lower::derefPassProcPointerComponent(
+    mlir::Location loc, Fortran::lower::AbstractConverter &converter,
+    const Fortran::evaluate::ProcedureDesignator &proc, mlir::Value passedArg,
+    Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
+  const Fortran::semantics::Symbol *procComponentSym = proc.GetSymbol();
+  assert(procComponentSym &&
+         "failed to retrieve pointer procedure component symbol");
+  hlfir::EntityWithAttributes pointerComp = designateProcedurePointerComponent(
+      loc, converter, *procComponentSym, passedArg, symMap, stmtCtx);
+  return converter.getFirOpBuilder().create<fir::LoadOp>(loc, pointerComp);
+}

flang/lib/Lower/ConvertType.cpp

@@ -140,7 +140,8 @@ namespace {
 struct TypeBuilderImpl {
 
   TypeBuilderImpl(Fortran::lower::AbstractConverter &converter)
-      : converter{converter}, context{&converter.getMLIRContext()} {}
+      : derivedTypeInConstruction{converter.getTypeConstructionStack()},
+        converter{converter}, context{&converter.getMLIRContext()} {}
 
   template <typename A>
   mlir::Type genExprType(const A &expr) {
@@ -398,8 +399,6 @@ struct TypeBuilderImpl {
         assert(scopeIter != derivedScope.cend() &&
                "failed to find derived type component symbol");
         const Fortran::semantics::Symbol &component = scopeIter->second.get();
-        if (IsProcedure(component))
-          TODO(converter.genLocation(component.name()), "procedure components");
         mlir::Type ty = genSymbolType(component);
         cs.emplace_back(converter.getRecordTypeFieldName(component), ty);
       }
@@ -568,8 +567,7 @@ struct TypeBuilderImpl {
   /// Stack derived type being processed to avoid infinite loops in case of
   /// recursive derived types. The depth of derived types is expected to be
   /// shallow (<10), so a SmallVector is sufficient.
-  llvm::SmallVector<std::pair<const Fortran::lower::SymbolRef, mlir::Type>>
-      derivedTypeInConstruction;
+  Fortran::lower::TypeConstructionStack &derivedTypeInConstruction;
   Fortran::lower::AbstractConverter &converter;
   mlir::MLIRContext *context;
 };