[flang][hlfir] Lower procedure designators to HLFIR

[jeanPerier]

Summary

• Add a convertProcedureDesignatorToHLFIR that converts the fir::ExtendedValue from the current lowering to a fir.boxproc/tuple<fir.boxproc, len> mlir::Value.

• Allow fir.boxproc/tuple<fir.boxproc, len> as hlfir::Entity values (a function is an address, but from a Fortran entity point of view, procedure that are not procedure pointers cannot be assigned to, so it makes a lot more sense to consider those as values).

• Modify symbol association to not generate an hlfir.declare for dummy procedures. They are not needed and allowing hlfir.declare to declare function values would make its verifier and handling overly complex for little benefits (maybe an hlfir.declare_proc could be added if it turnout out useful later for debug info and attributes storing purposes).

• Allow translation from hlfir::Entity to fir::ExtendedValue. convertToBox return type had to be relaxed because some intrinsics handles both object and procedure arguments and need to lower their object arguments "asBox". fir::BoxValue is not intended to carry dummy procedures (all its member functions would make little sense and its verifier does not accept such type). Note that AsAddr, AsValue and AsBox will always return the same MLIR value for procedure designators because they are always handled the same way in FIR.

[clementval]

LGTM

flang/include/flang/Lower/CallInterface.h

 
 /// Return the type of an argument that is a dummy procedure. This may be an
 /// mlir::FunctionType, but it can also be a more elaborate type based on the
 /// function type (like a tuple<function type, length type> for character
 /// functions).
 mlir::Type getDummyProcedureType(const Fortran::semantics::Symbol &dummyProc,
                                  Fortran::lower::AbstractConverter &);
 
+/// Return !fir.boxproc<() -> ()> type.
+mlir::Type getUntypedBoxProcType(mlir::MLIRContext *context);
+
 /// Return true if \p ty is "!fir.ref<i64>", which is the interface for
 /// type(C_PTR/C_FUNPTR) passed by value.
 bool isCPtrArgByValueType(mlir::Type ty);
 
 /// Is it required to pass \p proc as a tuple<function address, result length> ?
 // This is required to convey  the length of character functions passed as dummy
 // procedures.
 bool mustPassLengthWithDummyProcedure(
     const Fortran::evaluate::ProcedureDesignator &proc,
     Fortran::lower::AbstractConverter &);
 
 } // namespace Fortran::lower
 
 #endif // FORTRAN_LOWER_FIRBUILDER_H

flang/include/flang/Lower/ConvertExprToHLFIR.h

translateToExtendedValue(mlir::Location loc, fir::FirOpBuilder &builder,
                          Fortran::lower::StatementContext &context) {
   auto [exv, exvCleanup] =
       hlfir::translateToExtendedValue(loc, builder, entity);
   if (exvCleanup)
     context.attachCleanup(*exvCleanup);
   return exv;
 }
 
-/// Lower an evaluate::Expr to a fir::Box.
-fir::BoxValue convertExprToBox(mlir::Location loc,
+/// Lower an evaluate::Expr object to a fir.box, and a procedure designator to a
+/// fir.boxproc<>
+fir::ExtendedValue convertExprToBox(mlir::Location loc,
                                     Fortran::lower::AbstractConverter &,
                                     const Fortran::lower::SomeExpr &,
                                     Fortran::lower::SymMap &,
                                     Fortran::lower::StatementContext &);
-fir::BoxValue convertToBox(mlir::Location loc,
+fir::ExtendedValue convertToBox(mlir::Location loc,
                                 Fortran::lower::AbstractConverter &,
                                 hlfir::Entity entity,
                                 Fortran::lower::StatementContext &,
                                 mlir::Type fortranType);
 
 /// Lower an evaluate::Expr to fir::ExtendedValue address.
-/// The address may be a raw fir.ref<T>, or a fir.box<T>/fir.class<T>, (pointer
-/// and allocatable are dereferenced).
+/// The address may be a raw fir.ref<T>, or a fir.box<T>/fir.class<T>, or a
+/// fir.boxproc<>. Pointers and allocatable are dereferenced.
+/// - If the expression is a procedure designator, it is lowered to fir.boxproc
+/// (with an extra length for character function procedure designators).
 /// - If expression is not a variable, or is a designator with vector
 ///   subscripts, a temporary is created to hold the expression value and
 ///   is returned as:
 ///   - a fir.class<T> if the expression is polymorphic.
 ///   - otherwise, a fir.box<T> if it is a derived type with length
 ///     parameters (not yet implemented).
 ///   - otherwise, a fir.ref<T>
 /// - If the expression is a variable that is not a designator with

flang/include/flang/Lower/ConvertProcedureDesignator.h

 #define FORTRAN_LOWER_CONVERT_PROCEDURE_DESIGNATOR_H
 
 namespace mlir {
 class Location;
 }
 namespace fir {
 class ExtendedValue;
 }
+namespace hlfir {
+class EntityWithAttributes;
+}
 namespace Fortran::evaluate {
 struct ProcedureDesignator;
 }
 
 namespace Fortran::lower {
 class AbstractConverter;
 class StatementContext;
 class SymMap;
 
 /// Lower a procedure designator to a fir::ExtendedValue that can be a
 /// fir::CharBoxValue for character procedure designator (the CharBoxValue
 /// length carries the result length if it is known).
 fir::ExtendedValue convertProcedureDesignator(
     mlir::Location loc, Fortran::lower::AbstractConverter &converter,
     const Fortran::evaluate::ProcedureDesignator &proc,
     Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx);
 
+/// Lower a procedure designator to a !fir.boxproc<()->() or
+/// tuple<!fir.boxproc<()->(), len>.
+hlfir::EntityWithAttributes convertProcedureDesignatorToHLFIR(
+    mlir::Location loc, Fortran::lower::AbstractConverter &converter,
+    const Fortran::evaluate::ProcedureDesignator &proc,
+    Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx);
+
 } // namespace Fortran::lower
 #endif // FORTRAN_LOWER_CONVERT_PROCEDURE_DESIGNATOR_H

flang/include/flang/Optimizer/Builder/Character.h

 /// types are not the same as the one inside the tuple type \p tupleType.
 mlir::Value createCharacterProcedureTuple(fir::FirOpBuilder &builder,
                                           mlir::Location loc,
                                           mlir::Type tupleType,
                                           mlir::Value addr, mlir::Value len);
 
 /// Given a tuple containing a character function address and its result length,
 /// extract the tuple into a pair of value <function address, result length>.
+/// If openBoxProc is true, the function address is extracted from the
+/// fir.boxproc, otherwise, the returned function address is the fir.boxproc.
 std::pair<mlir::Value, mlir::Value>
 extractCharacterProcedureTuple(fir::FirOpBuilder &builder, mlir::Location loc,
-                               mlir::Value tuple);
+                               mlir::Value tuple, bool openBoxProc = true);
 
 } // namespace fir::factory
 
 #endif // FORTRAN_OPTIMIZER_BUILDER_CHARACTER_H

flang/include/flang/Optimizer/Builder/HLFIRTools.h

 }
 
 namespace hlfir {
 
 class AssociateOp;
 class ElementalOp;
 class YieldElementOp;
 
+/// Is this an SSA value type for the value of a Fortran procedure
+/// designator ?
+inline bool isFortranProcedureValue(mlir::Type type) {
+  return type.isa<fir::BoxProcType>() ||
+         (type.isa<mlir::TupleType>() &&
+          fir::isCharacterProcedureTuple(type, /*acceptRawFunc=*/false));
+}
+
 /// Is this an SSA value type for the value of a Fortran expression?
 inline bool isFortranValueType(mlir::Type type) {
-  return type.isa<hlfir::ExprType>() || fir::isa_trivial(type);
+  return type.isa<hlfir::ExprType>() || fir::isa_trivial(type) ||
+         isFortranProcedureValue(type);
 }
 
 /// Is this the value of a Fortran expression in an SSA value form?
 inline bool isFortranValue(mlir::Value value) {
   return isFortranValueType(value.getType());
 }
 
 /// Is this a Fortran variable?
public:
   Entity(fir::FortranVariableOpInterface variable)
       : mlir::Value(variable.getBase()) {}
   bool isValue() const { return isFortranValue(*this); }
   bool isVariable() const { return !isValue(); }
   bool isMutableBox() const { return hlfir::isBoxAddressType(getType()); }
   bool isBoxAddressOrValue() const {
     return hlfir::isBoxAddressOrValueType(getType());
   }
+
+  /// Is this entity a procedure designator?
+  bool isProcedure() const { return isFortranProcedureValue(getType()); }
+
   /// Is this an array or an assumed ranked entity?
   bool isArray() const { return getRank() != 0; }
 
   /// Return the rank of this entity or -1 if it is an assumed rank.
   int getRank() const {
     mlir::Type type = fir::unwrapPassByRefType(fir::unwrapRefType(getType()));
     if (auto seqTy = type.dyn_cast<fir::SequenceType>()) {
       if (seqTy.hasUnknownShape())

 std::pair<fir::ExtendedValue, std::optional<hlfir::CleanupFunction>>
 convertToValue(mlir::Location loc, fir::FirOpBuilder &builder,
                const hlfir::Entity &entity);
 
 std::pair<fir::ExtendedValue, std::optional<hlfir::CleanupFunction>>
 convertToAddress(mlir::Location loc, fir::FirOpBuilder &builder,
                  const hlfir::Entity &entity, mlir::Type targetType);
 
-std::pair<fir::BoxValue, std::optional<hlfir::CleanupFunction>>
+std::pair<fir::ExtendedValue, std::optional<hlfir::CleanupFunction>>
 convertToBox(mlir::Location loc, fir::FirOpBuilder &builder,
              const hlfir::Entity &entity, mlir::Type targetType);
 } // namespace hlfir
 
 #endif // FORTRAN_OPTIMIZER_BUILDER_HLFIRTOOLS_H

flang/lib/Lower/Bridge.cpp

if (lowerToHighLevelFIR()) {
         auto exv =
             hlfir::translateToExtendedValue(toLocation(), *builder, *var);
         return exv.match(
             [](mlir::Value x) -> Fortran::lower::SymbolBox {
               return Fortran::lower::SymbolBox::Intrinsic{x};
             },
             [](auto x) -> Fortran::lower::SymbolBox { return x; });
       }
+      // Procedure dummies are not mapped with an hlfir.declare because
+      // they are not "variable" (cannot be assigned to), and it would
+      // make hlfir.declare more complex than it needs to to allow this.
+      // Do a regular lookup.
+      if (Fortran::semantics::IsProcedure(sym))
+        return symMap->lookupSymbol(sym);
       return {};
     }
     if (Fortran::lower::SymbolBox v = symMap->lookupSymbol(sym))
       return v;
     return {};
   }
 
   /// Find the symbol in the inner-most level of the local map or return null.

flang/lib/Lower/CallInterface.cpp

static std::string getMangledName(mlir::Location loc,
   // TODO: update GetBindName so that it does not return a label for internal
   // procedures.
   if (bindName && Fortran::semantics::ClassifyProcedure(symbol) ==
                       Fortran::semantics::ProcedureDefinitionClass::Internal)
     TODO(loc, "BIND(C) internal procedures");
   return bindName ? *bindName : Fortran::lower::mangle::mangleName(symbol);
 }
 
+mlir::Type Fortran::lower::getUntypedBoxProcType(mlir::MLIRContext *context) {
+  llvm::SmallVector<mlir::Type> resultTys;
+  llvm::SmallVector<mlir::Type> inputTys;
+  auto untypedFunc = mlir::FunctionType::get(context, inputTys, resultTys);
+  return fir::BoxProcType::get(context, untypedFunc);
+}
+
 /// Return the type of a dummy procedure given its characteristic (if it has
 /// one).
-mlir::Type getProcedureDesignatorType(
+static mlir::Type getProcedureDesignatorType(
     const Fortran::evaluate::characteristics::Procedure *,
     Fortran::lower::AbstractConverter &converter) {
   // TODO: Get actual function type of the dummy procedure, at least when an
   // interface is given. The result type should be available even if the arity
   // and type of the arguments is not.
-  llvm::SmallVector<mlir::Type> resultTys;
-  llvm::SmallVector<mlir::Type> inputTys;
   // In general, that is a nice to have but we cannot guarantee to find the
   // function type that will match the one of the calls, we may not even know
   // how many arguments the dummy procedure accepts (e.g. if a procedure
   // pointer is only transiting through the current procedure without being
   // called), so a function type cast must always be inserted.
-  auto *context = &converter.getMLIRContext();
-  auto untypedFunc = mlir::FunctionType::get(context, inputTys, resultTys);
-  return fir::BoxProcType::get(context, untypedFunc);
+  return Fortran::lower::getUntypedBoxProcType(&converter.getMLIRContext());
 }
 
 //===----------------------------------------------------------------------===//
 // Caller side interface implementation
 //===----------------------------------------------------------------------===//
 
 bool Fortran::lower::CallerInterface::hasAlternateReturns() const {
   return procRef.hasAlternateReturns();

flang/lib/Lower/ConvertCall.cpp

static PreparedDummyArgument preparePresentUserCallActualArgument(
     const Fortran::lower::CallerInterface::PassedEntity &arg,
     const Fortran::lower::SomeExpr &expr,
     Fortran::evaluate::FoldingContext &foldingContext) {
 
   // Step 1: get the actual argument, which includes addressing the
   // element if this is an array in an elemental call.
   hlfir::Entity actual = preparedActual.getActual(loc, builder);
 
+  // Do nothing if this is a procedure argument. It is already a
+  // fir.boxproc/fir.tuple<fir.boxproc, len> as it should.
+  if (actual.isProcedure())
+    return PreparedDummyArgument{actual, std::nullopt};
+
   const bool passingPolymorphicToNonPolymorphic =
       actual.isPolymorphic() && !fir::isPolymorphicType(dummyType);
 
   // When passing a CLASS(T) to TYPE(T), only the "T" part must be
   // passed. Unless the entity is a scalar passed by raw address, a
   // new descriptor must be made using the dummy argument type as
   // dynamic type. This must be done before any copy/copy-in because the
   // dynamic type matters to determine the contiguity.
for (auto [preparedActual, arg] :
     } break;
     case PassBy::AddressAndLength:
       // PassBy::AddressAndLength is only used for character results. Results
       // are not handled here.
       fir::emitFatalError(
           loc, "unexpected PassBy::AddressAndLength for actual arguments");
       break;
     case PassBy::CharProcTuple: {
-      TODO(loc, "HLFIR PassBy::CharProcTuple");
+      hlfir::Entity actual = preparedActual->getActual(loc, builder);
+      assert(fir::isCharacterProcedureTuple(actual.getType()) &&
+             "character dummy procedure was not prepared as expected");
+      caller.placeInput(arg, actual);
     } break;
     case PassBy::MutableBox: {
       hlfir::Entity actual = preparedActual->getActual(loc, builder);
       if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
               *expr)) {
         // If expr is NULL(), the mutableBox created must be a deallocated
         // pointer with the dummy argument characteristics (see table 16.5
         // in Fortran 2018 standard).

flang/lib/Lower/ConvertExprToHLFIR.cpp

 //===----------------------------------------------------------------------===//
 
 #include "flang/Lower/ConvertExprToHLFIR.h"
 #include "flang/Evaluate/shape.h"
 #include "flang/Lower/AbstractConverter.h"
 #include "flang/Lower/CallInterface.h"
 #include "flang/Lower/ConvertCall.h"
 #include "flang/Lower/ConvertConstant.h"
+#include "flang/Lower/ConvertProcedureDesignator.h"
 #include "flang/Lower/ConvertType.h"
 #include "flang/Lower/ConvertVariable.h"
 #include "flang/Lower/StatementContext.h"
 #include "flang/Lower/SymbolMap.h"
 #include "flang/Optimizer/Builder/Complex.h"
 #include "flang/Optimizer/Builder/IntrinsicCall.h"
 #include "flang/Optimizer/Builder/MutableBox.h"
 #include "flang/Optimizer/Builder/Runtime/Character.h"
private:
   }
 
   hlfir::EntityWithAttributes gen(const Fortran::evaluate::NullPointer &expr) {
     auto nullop = getBuilder().create<hlfir::NullOp>(getLoc());
     return mlir::cast<fir::FortranVariableOpInterface>(nullop.getOperation());
   }
 
   hlfir::EntityWithAttributes
-  gen(const Fortran::evaluate::ProcedureDesignator &expr) {
-    TODO(getLoc(), "lowering ProcDes to HLFIR");
+  gen(const Fortran::evaluate::ProcedureDesignator &proc) {
+    return Fortran::lower::convertProcedureDesignatorToHLFIR(
+        getLoc(), getConverter(), proc, getSymMap(), getStmtCtx());
   }
+
   hlfir::EntityWithAttributes gen(const Fortran::evaluate::ProcedureRef &expr) {
     TODO(getLoc(), "lowering ProcRef to HLFIR");
   }
 
   template <typename T>
   hlfir::EntityWithAttributes
   gen(const Fortran::evaluate::Designator<T> &designator) {
     return HlfirDesignatorBuilder(getLoc(), getConverter(), getSymMap(),

 
 hlfir::EntityWithAttributes Fortran::lower::convertExprToHLFIR(
     mlir::Location loc, Fortran::lower::AbstractConverter &converter,
     const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap,
     Fortran::lower::StatementContext &stmtCtx) {
   return HlfirBuilder(loc, converter, symMap, stmtCtx).gen(expr);
 }
 
-fir::BoxValue Fortran::lower::convertToBox(
+fir::ExtendedValue Fortran::lower::convertToBox(
     mlir::Location loc, Fortran::lower::AbstractConverter &converter,
     hlfir::Entity entity, Fortran::lower::StatementContext &stmtCtx,
     mlir::Type fortranType) {
   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
   auto [exv, cleanup] = hlfir::convertToBox(loc, builder, entity, fortranType);
   if (cleanup)
     stmtCtx.attachCleanup(*cleanup);
   return exv;
 }
-fir::BoxValue Fortran::lower::convertExprToBox(
+
+fir::ExtendedValue Fortran::lower::convertExprToBox(
     mlir::Location loc, Fortran::lower::AbstractConverter &converter,
     const Fortran::lower::SomeExpr &expr, Fortran::lower::SymMap &symMap,
     Fortran::lower::StatementContext &stmtCtx) {
   hlfir::EntityWithAttributes loweredExpr =
       HlfirBuilder(loc, converter, symMap, stmtCtx).gen(expr);
   return convertToBox(loc, converter, loweredExpr, stmtCtx,
                       converter.genType(expr));
 }

flang/lib/Lower/ConvertProcedureDesignator.cpp

if (Fortran::lower::mustPassLengthWithDummyProcedure(proc, converter)) {
     }
     if (!funcPtrResultLength)
       funcPtrResultLength = builder.createIntegerConstant(
           loc, builder.getCharacterLengthType(), -1);
     return fir::CharBoxValue{funcPtr, funcPtrResultLength};
   }
   return funcPtr;
 }
+
+hlfir::EntityWithAttributes Fortran::lower::convertProcedureDesignatorToHLFIR(
+    mlir::Location loc, Fortran::lower::AbstractConverter &converter,
+    const Fortran::evaluate::ProcedureDesignator &proc,
+    Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
+  fir::ExtendedValue procExv =
+      convertProcedureDesignator(loc, converter, proc, symMap, stmtCtx);
+  // Directly package the procedure address as a fir.boxproc or
+  // tuple<fir.boxbroc, len> so that it can be returned as a single mlir::Value.
+  fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+
+  mlir::Value funcAddr = fir::getBase(procExv);
+  if (!funcAddr.getType().isa<fir::BoxProcType>()) {
+    mlir::Type boxTy =
+        Fortran::lower::getUntypedBoxProcType(&converter.getMLIRContext());
+    if (auto host = Fortran::lower::argumentHostAssocs(converter, funcAddr))
+      funcAddr = builder.create<fir::EmboxProcOp>(
+          loc, boxTy, llvm::ArrayRef<mlir::Value>{funcAddr, host});
+    else
+      funcAddr = builder.create<fir::EmboxProcOp>(loc, boxTy, funcAddr);
+  }
+
+  mlir::Value res = procExv.match(
+      [&](const fir::CharBoxValue &box) -> mlir::Value {
+        mlir::Type tupleTy =
+            fir::factory::getCharacterProcedureTupleType(funcAddr.getType());
+        return fir::factory::createCharacterProcedureTuple(
+            builder, loc, tupleTy, funcAddr, box.getLen());
+      },
+      [funcAddr](const auto &) { return funcAddr; });
+  return hlfir::EntityWithAttributes{res};
+}

flang/lib/Lower/ConvertVariable.cpp

 /// Will optionally create fir.declare.
 static void genDeclareSymbol(Fortran::lower::AbstractConverter &converter,
                              Fortran::lower::SymMap &symMap,
                              const Fortran::semantics::Symbol &sym,
                              mlir::Value base, mlir::Value len = {},
                              llvm::ArrayRef<mlir::Value> shape = std::nullopt,
                              llvm::ArrayRef<mlir::Value> lbounds = std::nullopt,
                              bool force = false) {
-  if (converter.getLoweringOptions().getLowerToHighLevelFIR()) {
+  // In HLFIR, procedure dummy symbols are not added with an hlfir.declare
+  // because they are "values", and hlfir.declare is intended for variables. It
+  // would add too much complexity to hlfir.declare to support this case, and
+  // this would bring very little (the only point being debug info, that are not
+  // yet emitted) since alias analysis is meaningless for those.
+  if (converter.getLoweringOptions().getLowerToHighLevelFIR() &&
+      !Fortran::semantics::IsProcedure(sym)) {
     fir::FirOpBuilder &builder = converter.getFirOpBuilder();
     const mlir::Location loc = genLocation(converter, sym);
     mlir::Value shapeOrShift;
     if (!shape.empty() && !lbounds.empty())
       shapeOrShift = builder.genShape(loc, lbounds, shape);
     else if (!shape.empty())
       shapeOrShift = builder.genShape(loc, shape);
     else if (!lbounds.empty())

 }
 
 /// Map a symbol to its FIR address and evaluated specification expressions
 /// provided as a fir::ExtendedValue. Will optionally create fir.declare.
 void Fortran::lower::genDeclareSymbol(
     Fortran::lower::AbstractConverter &converter,
     Fortran::lower::SymMap &symMap, const Fortran::semantics::Symbol &sym,
     const fir::ExtendedValue &exv, bool force) {
-  if (converter.getLoweringOptions().getLowerToHighLevelFIR()) {
+  if (converter.getLoweringOptions().getLowerToHighLevelFIR() &&
+      !Fortran::semantics::IsProcedure(sym)) {
     fir::FirOpBuilder &builder = converter.getFirOpBuilder();
     const mlir::Location loc = genLocation(converter, sym);
     fir::FortranVariableFlagsAttr attributes =
         Fortran::lower::translateSymbolAttributes(builder.getContext(), sym);
     auto name = Fortran::lower::mangle::mangleName(sym);
     hlfir::EntityWithAttributes declare =
         hlfir::genDeclare(loc, builder, exv, name, attributes);
     symMap.addVariableDefinition(sym, declare.getIfVariableInterface(), force);

flang/lib/Optimizer/Builder/Character.cpp

mlir::Value fir::factory::CharacterExprHelper::getLength(mlir::Value memref) {
 
   // Length cannot be deduced from memref.
   return {};
 }
 
 std::pair<mlir::Value, mlir::Value>
 fir::factory::extractCharacterProcedureTuple(fir::FirOpBuilder &builder,
                                              mlir::Location loc,
-                                             mlir::Value tuple) {
+                                             mlir::Value tuple,
+                                             bool openBoxProc) {
   mlir::TupleType tupleType = tuple.getType().cast<mlir::TupleType>();
   mlir::Value addr = builder.create<fir::ExtractValueOp>(
       loc, tupleType.getType(0), tuple,
       builder.getArrayAttr(
           {builder.getIntegerAttr(builder.getIndexType(), 0)}));
   mlir::Value proc = [&]() -> mlir::Value {
+    if (openBoxProc)
       if (auto addrTy = addr.getType().dyn_cast<fir::BoxProcType>())
         return builder.create<fir::BoxAddrOp>(loc, addrTy.getEleTy(), addr);
     return addr;
   }();
   mlir::Value len = builder.create<fir::ExtractValueOp>(
       loc, tupleType.getType(1), tuple,
       builder.getArrayAttr(
           {builder.getIntegerAttr(builder.getIndexType(), 1)}));
   return {proc, len};
 }

flang/lib/Optimizer/Builder/HLFIRTools.cpp

 
 std::pair<fir::ExtendedValue, std::optional<hlfir::CleanupFunction>>
 hlfir::translateToExtendedValue(mlir::Location loc, fir::FirOpBuilder &builder,
                                 hlfir::Entity entity) {
   if (entity.isVariable())
     return {translateVariableToExtendedValue(loc, builder, entity),
             std::nullopt};
 
+  if (entity.isProcedure()) {
+    if (fir::isCharacterProcedureTuple(entity.getType())) {
+      auto [boxProc, len] = fir::factory::extractCharacterProcedureTuple(
+          builder, loc, entity, /*openBoxProc=*/false);
+      return {fir::CharBoxValue{boxProc, len}, std::nullopt};
+    }
+    return {static_cast<mlir::Value>(entity), std::nullopt};
+  }
+
   if (entity.getType().isa<hlfir::ExprType>()) {
     hlfir::AssociateOp associate = hlfir::genAssociateExpr(
         loc, builder, entity, entity.getType(), "adapt.valuebyref");
     auto *bldr = &builder;
     hlfir::CleanupFunction cleanup = [bldr, loc, associate]() -> void {
       bldr->create<hlfir::EndAssociateOp>(loc, associate);
     };
     hlfir::Entity temp{associate.getBase()};
static fir::ExtendedValue placeTrivialInMemory(mlir::Location loc,
   auto temp = builder.createTemporary(loc, targetType);
   if (targetType != val.getType())
     builder.createStoreWithConvert(loc, val, temp);
   else
     builder.create<fir::StoreOp>(loc, val, temp);
   return temp;
 }
 
-std::pair<fir::BoxValue, std::optional<hlfir::CleanupFunction>>
+std::pair<fir::ExtendedValue, std::optional<hlfir::CleanupFunction>>
 hlfir::convertToBox(mlir::Location loc, fir::FirOpBuilder &builder,
                     const hlfir::Entity &entity, mlir::Type targetType) {
   auto [exv, cleanup] = translateToExtendedValue(loc, builder, entity);
+  // Procedure entities should not go through createBoxValue that embox
+  // object entities. Return the fir.boxproc directly.
+  if (entity.isProcedure())
+    return {exv, cleanup};
   mlir::Value base = fir::getBase(exv);
   if (fir::isa_trivial(base.getType()))
     exv = placeTrivialInMemory(loc, builder, base, targetType);
   fir::BoxValue box = fir::factory::createBoxValue(builder, loc, exv);
   return {box, cleanup};
 }
 
 std::pair<fir::ExtendedValue, std::optional<hlfir::CleanupFunction>>

flang/test/Lower/HLFIR/procedure-designators.f90

+! Test lowering of procedure designators to HLFIR.
+! RUN: bbc -emit-fir -hlfir -o - %s | FileCheck %s
+
+module test_proc_designator
+  interface
+    subroutine simple()
+    end subroutine
+    character(10) function return_char(x)
+       integer :: x
+    end function
+  end interface
+contains
+
+subroutine test_pass_simple()
+  call takes_simple(simple)
+end subroutine
+! CHECK-LABEL: func.func @_QMtest_proc_designatorPtest_pass_simple() {
+! CHECK:  %[[VAL_0:.*]] = fir.address_of(@_QPsimple) : () -> ()
+! CHECK:  %[[VAL_1:.*]] = fir.emboxproc %[[VAL_0]] : (() -> ()) -> !fir.boxproc<() -> ()>
+! CHECK:  fir.call @_QPtakes_simple(%[[VAL_1]]) {{.*}}: (!fir.boxproc<() -> ()>) -> ()
+
+subroutine test_pass_character()
+  call takes_char_proc(return_char)
+end subroutine
+! CHECK-LABEL: func.func @_QMtest_proc_designatorPtest_pass_character() {
+! CHECK:  %[[VAL_0:.*]] = fir.address_of(@_QPreturn_char) : (!fir.ref<!fir.char<1,10>>, index, !fir.ref<i32>) -> !fir.boxchar<1>
+! CHECK:  %[[VAL_1:.*]] = arith.constant 10 : i64
+! CHECK:  %[[VAL_2:.*]] = fir.emboxproc %[[VAL_0]] : ((!fir.ref<!fir.char<1,10>>, index, !fir.ref<i32>) -> !fir.boxchar<1>) -> !fir.boxproc<() -> ()>
+! CHECK:  %[[VAL_3:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK:  %[[VAL_4:.*]] = fir.insert_value %[[VAL_3]], %[[VAL_2]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK:  %[[VAL_5:.*]] = fir.insert_value %[[VAL_4]], %[[VAL_1]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK:  fir.call @_QPtakes_char_proc(%[[VAL_5]]) {{.*}}: (tuple<!fir.boxproc<() -> ()>, i64>) -> ()
+
+subroutine test_pass_simple_dummy(proc)
+  procedure(simple) :: proc
+  call takes_simple(proc)
+end subroutine
+! CHECK-LABEL: func.func @_QMtest_proc_designatorPtest_pass_simple_dummy(
+! CHECK-SAME:    %[[VAL_0:.*]]: !fir.boxproc<() -> ()>) {
+! CHECK:  fir.call @_QPtakes_simple(%[[VAL_0]]) {{.*}}: (!fir.boxproc<() -> ()>) -> ()
+
+subroutine test_pass_character_dummy(proc)
+  procedure(return_char) :: proc
+  call takes_char_proc(proc)
+end subroutine
+! CHECK-LABEL: func.func @_QMtest_proc_designatorPtest_pass_character_dummy(
+! CHECK-SAME:    %[[VAL_0:.*]]: tuple<!fir.boxproc<() -> ()>, i64> {fir.char_proc}) {
+! CHECK:  %[[VAL_1:.*]] = fir.extract_value %[[VAL_0]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
+! CHECK:  %[[VAL_2:.*]] = fir.box_addr %[[VAL_1]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+! CHECK:  %[[VAL_3:.*]] = arith.constant 10 : i64
+! CHECK:  %[[VAL_4:.*]] = fir.emboxproc %[[VAL_2]] : (() -> ()) -> !fir.boxproc<() -> ()>
+! CHECK:  %[[VAL_5:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK:  %[[VAL_6:.*]] = fir.insert_value %[[VAL_5]], %[[VAL_4]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK:  %[[VAL_7:.*]] = fir.insert_value %[[VAL_6]], %[[VAL_3]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK:  fir.call @_QPtakes_char_proc(%[[VAL_7]]) {{.*}}: (tuple<!fir.boxproc<() -> ()>, i64>) -> ()
+
+subroutine test_pass_character_dummy_2(proc)
+  character(*), external :: proc
+  call takes_char_proc(proc)
+end subroutine
+! CHECK-LABEL: func.func @_QMtest_proc_designatorPtest_pass_character_dummy_2(
+! CHECK-SAME:    %[[VAL_0:.*]]: tuple<!fir.boxproc<() -> ()>, i64> {fir.char_proc}) {
+! CHECK:  %[[VAL_1:.*]] = fir.extract_value %[[VAL_0]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
+! CHECK:  %[[VAL_2:.*]] = fir.box_addr %[[VAL_1]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+! CHECK:  %[[VAL_3:.*]] = fir.extract_value %[[VAL_0]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> i64
+! CHECK:  %[[VAL_4:.*]] = fir.emboxproc %[[VAL_2]] : (() -> ()) -> !fir.boxproc<() -> ()>
+! CHECK:  %[[VAL_5:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK:  %[[VAL_6:.*]] = fir.insert_value %[[VAL_5]], %[[VAL_4]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK:  %[[VAL_7:.*]] = fir.insert_value %[[VAL_6]], %[[VAL_3]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK:  fir.call @_QPtakes_char_proc(%[[VAL_7]]) {{.*}}: (tuple<!fir.boxproc<() -> ()>, i64>) -> ()
+
+subroutine test_pass_simple_internal()
+  integer :: x
+  call takes_simple(simple_internal)
+contains
+subroutine simple_internal()
+  x = 42
+end subroutine
+end subroutine
+! CHECK-LABEL: func.func @_QMtest_proc_designatorPtest_pass_simple_internal() {
+! CHECK:  %[[VAL_1:.*]]:2 = hlfir.declare {{.*}}Ex
+! CHECK:  %[[VAL_2:.*]] = fir.alloca tuple<!fir.ref<i32>>
+! CHECK:  %[[VAL_3:.*]] = arith.constant 0 : i32
+! CHECK:  %[[VAL_4:.*]] = fir.coordinate_of %[[VAL_2]], %[[VAL_3]] : (!fir.ref<tuple<!fir.ref<i32>>>, i32) -> !fir.llvm_ptr<!fir.ref<i32>>
+! CHECK:  fir.store %[[VAL_1]]#1 to %[[VAL_4]] : !fir.llvm_ptr<!fir.ref<i32>>
+! CHECK:  %[[VAL_5:.*]] = fir.address_of(@_QMtest_proc_designatorFtest_pass_simple_internalPsimple_internal) : (!fir.ref<tuple<!fir.ref<i32>>>) -> ()
+! CHECK:  %[[VAL_6:.*]] = fir.emboxproc %[[VAL_5]], %[[VAL_2]] : ((!fir.ref<tuple<!fir.ref<i32>>>) -> (), !fir.ref<tuple<!fir.ref<i32>>>) -> !fir.boxproc<() -> ()>
+! CHECK:  fir.call @_QPtakes_simple(%[[VAL_6]]) {{.*}}: (!fir.boxproc<() -> ()>) -> ()
+
+subroutine test_pass_character_internal()
+  integer :: x
+  call takes_char_proc(return_char_internal)
+contains
+character(10) function return_char_internal()
+  return_char_internal = char(x)
+end function
+end subroutine
+! CHECK-LABEL: func.func @_QMtest_proc_designatorPtest_pass_character_internal() {
+! CHECK:  %[[VAL_1:.*]]:2 = hlfir.declare {{.*}}Ex
+! CHECK:  %[[VAL_2:.*]] = fir.alloca tuple<!fir.ref<i32>>
+! CHECK:  %[[VAL_3:.*]] = arith.constant 0 : i32
+! CHECK:  %[[VAL_4:.*]] = fir.coordinate_of %[[VAL_2]], %[[VAL_3]] : (!fir.ref<tuple<!fir.ref<i32>>>, i32) -> !fir.llvm_ptr<!fir.ref<i32>>
+! CHECK:  fir.store %[[VAL_1]]#1 to %[[VAL_4]] : !fir.llvm_ptr<!fir.ref<i32>>
+! CHECK:  %[[VAL_5:.*]] = fir.address_of(@_QMtest_proc_designatorFtest_pass_character_internalPreturn_char_internal) : (!fir.ref<!fir.char<1,10>>, index, !fir.ref<tuple<!fir.ref<i32>>>) -> !fir.boxchar<1>
+! CHECK:  %[[VAL_6:.*]] = arith.constant 10 : i64
+! CHECK:  %[[VAL_7:.*]] = fir.emboxproc %[[VAL_5]], %[[VAL_2]] : ((!fir.ref<!fir.char<1,10>>, index, !fir.ref<tuple<!fir.ref<i32>>>) -> !fir.boxchar<1>, !fir.ref<tuple<!fir.ref<i32>>>) -> !fir.boxproc<() -> ()>
+! CHECK:  %[[VAL_8:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK:  %[[VAL_9:.*]] = fir.insert_value %[[VAL_8]], %[[VAL_7]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK:  %[[VAL_10:.*]] = fir.insert_value %[[VAL_9]], %[[VAL_6]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK:  fir.call @_QPtakes_char_proc(%[[VAL_10]]) {{.*}}: (tuple<!fir.boxproc<() -> ()>, i64>) -> ()
+
+
+subroutine test_call_simple_dummy(proc)
+  procedure(simple) :: proc
+  call proc()
+end subroutine
+! CHECK-LABEL: func.func @_QMtest_proc_designatorPtest_call_simple_dummy(
+! CHECK-SAME:    %[[VAL_0:.*]]: !fir.boxproc<() -> ()>) {
+! CHECK:  %[[VAL_1:.*]] = fir.box_addr %[[VAL_0]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+! CHECK:  fir.call %[[VAL_1]]() {{.*}}: () -> ()
+
+subroutine test_call_character_dummy(proc)
+  procedure(return_char) :: proc
+  call takes_char(proc(42))
+end subroutine
+! CHECK-LABEL: func.func @_QMtest_proc_designatorPtest_call_character_dummy(
+! CHECK-SAME:    %[[VAL_0:.*]]: tuple<!fir.boxproc<() -> ()>, i64> {fir.char_proc}) {
+! CHECK:  %[[VAL_1:.*]] = fir.alloca !fir.char<1,10> {bindc_name = ".result"}
+! CHECK:  %[[VAL_4:.*]] = fir.extract_value %[[VAL_0]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
+! CHECK:  %[[VAL_5:.*]] = fir.box_addr %[[VAL_4]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+! CHECK:  %[[VAL_12:.*]] = fir.convert %[[VAL_5]] : (() -> ()) -> ((!fir.ref<!fir.char<1,10>>, index, !fir.ref<i32>) -> !fir.boxchar<1>)
+! CHECK:  %[[VAL_13:.*]] = fir.call %[[VAL_12]](%[[VAL_1]], {{.*}}
+
+subroutine test_present_simple_dummy(proc)
+  procedure(simple), optional :: proc
+  call takes_logical(present(proc))
+end subroutine
+! CHECK-LABEL: func.func @_QMtest_proc_designatorPtest_present_simple_dummy(
+! CHECK-SAME:    %[[VAL_0:.*]]: !fir.boxproc<() -> ()>) {
+! CHECK:  %[[VAL_1:.*]] = fir.is_present %[[VAL_0]] : (!fir.boxproc<() -> ()>) -> i1
+
+subroutine test_present_character_dummy(proc)
+  procedure(return_char), optional :: proc
+  call takes_logical(present(proc))
+end subroutine
+! CHECK-LABEL: func.func @_QMtest_proc_designatorPtest_present_character_dummy(
+! CHECK-SAME:    %[[VAL_0:.*]]: tuple<!fir.boxproc<() -> ()>, i64> {fir.char_proc}) {
+! CHECK:  %[[VAL_1:.*]] = fir.extract_value %[[VAL_0]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
+! CHECK:  %[[VAL_2:.*]] = fir.box_addr %[[VAL_1]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+! CHECK:  %[[VAL_3:.*]] = arith.constant 10 : i64
+! CHECK:  %[[VAL_4:.*]] = fir.emboxproc %[[VAL_2]] : (() -> ()) -> !fir.boxproc<() -> ()>
+! CHECK:  %[[VAL_5:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK:  %[[VAL_6:.*]] = fir.insert_value %[[VAL_5]], %[[VAL_4]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK:  %[[VAL_7:.*]] = fir.insert_value %[[VAL_6]], %[[VAL_3]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK:  %[[VAL_8:.*]] = fir.extract_value %[[VAL_7]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
+! CHECK:  %[[VAL_9:.*]] = fir.is_present %[[VAL_8]] : (!fir.boxproc<() -> ()>) -> i1
+
+end module