[flang][hlfir] Lower intrinsic module procedures to HLFIR

[jeanPerier]

Summary

Intrinsic module procedures are a bit different from intrinsic
procedures: they are defined in intrinsic module files, but their
signature and representation in semantics is the same as user
procedures.
The code to lower them in lowering (when they are not implemented in
Fortran) is the same as for intrinsic procedures
(Optimizer/Builder/IntrinsicCall.cpp).

The dispatching in in HLFIR procedure reference lowering must be
slightly modified so that these evaluate::ProcRef that have a
semantics::Symbol instead of an evaluate::SpecificIntrinsic can
be dispatched as evaluate::SpecificIntrinsic:

• move isIntrinsicModuleProcedure to detect them
• in the helpers dealing with intrinsics, make evaluate::SpecificIntrinsic a pointer argument that can be null for intrinsic module procedures.
• add getProcedureName() to call context to avoid relying on the evaluate::SpecificIntrinsic when it is not know to be null.

[clementval]

LGTM

flang/include/flang/Lower/ConvertCall.h

fir::ExtendedValue genCallOpAndResult(
     std::optional<mlir::Type> resultType);
 
 /// If \p arg is the address of a function with a denoted host-association tuple
 /// argument, then return the host-associations tuple value of the current
 /// procedure. Otherwise, return nullptr.
 mlir::Value argumentHostAssocs(Fortran::lower::AbstractConverter &converter,
                                mlir::Value arg);
 
+/// Is \p procRef an intrinsic module procedure that should be lowered as
+/// intrinsic procedures (with Optimizer/Builder/IntrinsicCall.h)?
+bool isIntrinsicModuleProcRef(const Fortran::evaluate::ProcedureRef &procRef);
+
 /// Lower a ProcedureRef to HLFIR. If this is a function call, return the
 /// lowered result value. Return nothing otherwise.
 std::optional<hlfir::EntityWithAttributes> convertCallToHLFIR(
     mlir::Location loc, Fortran::lower::AbstractConverter &converter,
     const evaluate::ProcedureRef &procRef, std::optional<mlir::Type> resultType,
     Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx);
 
 } // namespace Fortran::lower
 #endif // FORTRAN_LOWER_CONVERTCALL_H

flang/lib/Lower/ConvertCall.cpp

 #include "llvm/Support/CommandLine.h"
 #include "llvm/Support/Debug.h"
 #include <optional>
 
 #define DEBUG_TYPE "flang-lower-expr"
 
 static llvm::cl::opt<bool> useHlfirIntrinsicOps(
     "use-hlfir-intrinsic-ops", llvm::cl::init(true),
-    llvm::cl::desc("Lower via HLFIR transformational intrinsic operations such as hlfir.sum"));
+    llvm::cl::desc("Lower via HLFIR transformational intrinsic operations such "
+                   "as hlfir.sum"));
 
 /// Helper to package a Value and its properties into an ExtendedValue.
 static fir::ExtendedValue toExtendedValue(mlir::Location loc, mlir::Value base,
                                           llvm::ArrayRef<mlir::Value> extents,
                                           llvm::ArrayRef<mlir::Value> lengths) {
   mlir::Type type = base.getType();
   if (type.isa<fir::BaseBoxType>())
     return fir::BoxValue(base, /*lbounds=*/{}, lengths, extents);
CallContext(const Fortran::evaluate::ProcedureRef &procRef,
               Fortran::lower::AbstractConverter &converter,
               Fortran::lower::SymMap &symMap,
               Fortran::lower::StatementContext &stmtCtx)
       : procRef{procRef}, converter{converter}, symMap{symMap},
         stmtCtx{stmtCtx}, resultType{resultType}, loc{loc} {}
 
   fir::FirOpBuilder &getBuilder() { return converter.getFirOpBuilder(); }
 
+  std::string getProcedureName() const { return procRef.proc().GetName(); }
+
   /// Is this a call to an elemental procedure with at least one array argument?
   bool isElementalProcWithArrayArgs() const {
     if (procRef.IsElemental())
       for (const std::optional<Fortran::evaluate::ActualArgument> &arg :
            procRef.arguments())
         if (arg && arg->Rank() != 0)
           return true;
     return false;
genUserCall(PreparedActualArguments &loweredActuals,
   // TODO: "move" non pointer results into hlfir.expr.
   return extendedValueToHlfirEntity(loc, builder, result, ".tmp.func_result");
 }
 
 /// Lower calls to intrinsic procedures with actual arguments that have been
 /// pre-lowered but have not yet been prepared according to the interface.
 static std::optional<hlfir::EntityWithAttributes>
 genIntrinsicRefCore(PreparedActualArguments &loweredActuals,
-                    const Fortran::evaluate::SpecificIntrinsic &intrinsic,
+                    const Fortran::evaluate::SpecificIntrinsic *intrinsic,
                     const fir::IntrinsicArgumentLoweringRules *argLowering,
                     CallContext &callContext) {
   llvm::SmallVector<fir::ExtendedValue> operands;
   auto &stmtCtx = callContext.stmtCtx;
   auto &converter = callContext.converter;
   fir::FirOpBuilder &builder = callContext.getBuilder();
   mlir::Location loc = callContext.loc;
   for (auto arg : llvm::enumerate(loweredActuals)) {
for (auto arg : llvm::enumerate(loweredActuals)) {
     }
     llvm_unreachable("bad switch");
   }
   // genIntrinsicCall needs the scalar type, even if this is a transformational
   // procedure returning an array.
   std::optional<mlir::Type> scalarResultType;
   if (callContext.resultType)
     scalarResultType = hlfir::getFortranElementType(*callContext.resultType);
+  const std::string intrinsicName = callContext.getProcedureName();
   // Let the intrinsic library lower the intrinsic procedure call.
-  auto [resultExv, mustBeFreed] =
-      genIntrinsicCall(callContext.getBuilder(), loc, intrinsic.name,
-                       scalarResultType, operands);
+  auto [resultExv, mustBeFreed] = genIntrinsicCall(
+      callContext.getBuilder(), loc, intrinsicName, scalarResultType, operands);
   if (!fir::getBase(resultExv))
     return std::nullopt;
   hlfir::EntityWithAttributes resultEntity = extendedValueToHlfirEntity(
       loc, builder, resultExv, ".tmp.intrinsic_result");
   // Move result into memory into an hlfir.expr since they are immutable from
   // that point, and the result storage is some temp.
   if (resultEntity.isVariable()) {
     hlfir::AsExprOp asExpr;
     // Character/Derived MERGE lowering returns one of its argument address
     // (this is the only intrinsic implemented in that way so far). The
     // ownership of this address cannot be taken here since it may not be a
     // temp.
-    if (intrinsic.name == "merge")
+    if (intrinsicName == "merge")
       asExpr = builder.create<hlfir::AsExprOp>(loc, resultEntity);
     else
       asExpr = builder.create<hlfir::AsExprOp>(
           loc, resultEntity, builder.createBool(loc, mustBeFreed));
     resultEntity = hlfir::EntityWithAttributes{asExpr.getResult()};
   }
   return resultEntity;
 }
 
 /// Lower calls to intrinsic procedures with actual arguments that have been
 /// pre-lowered but have not yet been prepared according to the interface.
 static std::optional<hlfir::EntityWithAttributes>
 genHLFIRIntrinsicRefCore(PreparedActualArguments &loweredActuals,
-                         const Fortran::evaluate::SpecificIntrinsic &intrinsic,
+                         const Fortran::evaluate::SpecificIntrinsic *intrinsic,
                          const fir::IntrinsicArgumentLoweringRules *argLowering,
                          CallContext &callContext) {
   if (!useHlfirIntrinsicOps)
-    return genIntrinsicRefCore(loweredActuals, intrinsic, argLowering, callContext);
+    return genIntrinsicRefCore(loweredActuals, intrinsic, argLowering,
+                               callContext);
 
   fir::FirOpBuilder &builder = callContext.getBuilder();
   mlir::Location loc = callContext.loc;
 
   auto getOperandVector = [&](PreparedActualArguments &loweredActuals) {
     llvm::SmallVector<mlir::Value> operands;
     operands.reserve(loweredActuals.size());
 
if (auto array = normalisedResult.dyn_cast<fir::SequenceType>()) {
       resultShape = hlfir::ExprType::Shape{array.getShape()};
       elementType = array.getEleTy();
     } else {
       elementType = normalisedResult;
     }
     return hlfir::ExprType::get(builder.getContext(), resultShape, elementType,
                                 /*polymorphic=*/false);
   };
-
-  if (intrinsic.name == "sum") {
+  const std::string intrinsicName = callContext.getProcedureName();
+  if (intrinsicName == "sum") {
     llvm::SmallVector<mlir::Value> operands = getOperandVector(loweredActuals);
     assert(operands.size() == 3);
     mlir::Value array = operands[0];
     mlir::Value dim = operands[1];
     if (dim)
       dim = hlfir::loadTrivialScalar(loc, builder, hlfir::Entity{dim});
     mlir::Value mask = operands[2];
     mlir::Type resultTy = computeResultType(array, *callContext.resultType);
     // dim, mask can be NULL if these arguments were not given
     hlfir::SumOp sumOp =
         builder.create<hlfir::SumOp>(loc, resultTy, array, dim, mask);
     return {hlfir::EntityWithAttributes{sumOp.getResult()}};
   }
-  if (intrinsic.name == "matmul") {
+  if (intrinsicName == "matmul") {
     llvm::SmallVector<mlir::Value> operands = getOperandVector(loweredActuals);
     mlir::Type resultTy =
         computeResultType(operands[0], *callContext.resultType);
     hlfir::MatmulOp matmulOp = builder.create<hlfir::MatmulOp>(
         loc, resultTy, operands[0], operands[1]);
 
     return {hlfir::EntityWithAttributes{matmulOp.getResult()}};
   }
-  if (intrinsic.name == "transpose") {
+  if (intrinsicName == "transpose") {
     llvm::SmallVector<mlir::Value> operands = getOperandVector(loweredActuals);
     hlfir::ExprType::Shape resultShape;
     mlir::Type normalisedResult =
         hlfir::getFortranElementOrSequenceType(*callContext.resultType);
     auto array = normalisedResult.cast<fir::SequenceType>();
     llvm::ArrayRef<int64_t> arrayShape = array.getShape();
     assert(arrayShape.size() == 2 && "arguments to transpose have a rank of 2");
     mlir::Type elementType = array.getEleTy();
private:
   Fortran::lower::CallerInterface &caller;
   mlir::FunctionType callSiteType;
 };
 
 class ElementalIntrinsicCallBuilder
     : public ElementalCallBuilder<ElementalIntrinsicCallBuilder> {
 public:
   ElementalIntrinsicCallBuilder(
-      const Fortran::evaluate::SpecificIntrinsic &intrinsic,
+      const Fortran::evaluate::SpecificIntrinsic *intrinsic,
       const fir::IntrinsicArgumentLoweringRules *argLowering, bool isFunction)
       : intrinsic{intrinsic}, argLowering{argLowering}, isFunction{isFunction} {
   }
   std::optional<hlfir::Entity>
   genElementalKernel(PreparedActualArguments &loweredActuals,
                      CallContext &callContext) {
     return genHLFIRIntrinsicRefCore(loweredActuals, intrinsic, argLowering,
                                     callContext);
   }
   // Elemental intrinsic functions cannot modify their arguments.
   bool argMayBeModifiedByCall(int) const { return !isFunction; }
   bool canLoadActualArgumentBeforeLoop(int) const {
     // Elemental intrinsic functions never need the actual addresses
     // of their arguments.
     return isFunction;
   }
 
   mlir::Value
   computeDynamicCharacterResultLength(PreparedActualArguments &loweredActuals,
                                       CallContext &callContext) {
-    if (intrinsic.name == "adjustr" || intrinsic.name == "adjustl" ||
-        intrinsic.name == "merge")
+    if (intrinsic)
+      if (intrinsic->name == "adjustr" || intrinsic->name == "adjustl" ||
+          intrinsic->name == "merge")
         return hlfir::genCharLength(
             callContext.loc, callContext.getBuilder(),
             loweredActuals[0].value().getOriginalActual());
     // Character MIN/MAX is the min/max of the arguments length that are
     // present.
     TODO(callContext.loc,
          "compute elemental character min/max function result length in HLFIR");
   }
 
 private:
-  const Fortran::evaluate::SpecificIntrinsic &intrinsic;
+  const Fortran::evaluate::SpecificIntrinsic *intrinsic;
   const fir::IntrinsicArgumentLoweringRules *argLowering;
   const bool isFunction;
 };
 } // namespace
 
 static std::optional<mlir::Value>
 genIsPresentIfArgMaybeAbsent(mlir::Location loc, hlfir::Entity actual,
                              const Fortran::lower::SomeExpr &expr,
genIsPresentIfArgMaybeAbsent(mlir::Location loc, hlfir::Entity actual,
   // May fall into the category above if the allocatable is not optional.
 
   // Passing an optional to an optional.
   return builder.create<fir::IsPresentOp>(loc, builder.getI1Type(), actual)
       .getResult();
 }
 
 /// Lower an intrinsic procedure reference.
+/// \p intrinsic is null if this is an intrinsic module procedure that must be
+/// lowered as if it were an intrinsic module procedure (like C_LOC which is a
+/// procedure from intrinsic module iso_c_binding). Otherwise, \p intrinsic
+/// must not be null.
 static std::optional<hlfir::EntityWithAttributes>
-genIntrinsicRef(const Fortran::evaluate::SpecificIntrinsic &intrinsic,
+genIntrinsicRef(const Fortran::evaluate::SpecificIntrinsic *intrinsic,
                 CallContext &callContext) {
   mlir::Location loc = callContext.loc;
   auto &converter = callContext.converter;
-  if (Fortran::lower::intrinsicRequiresCustomOptionalHandling(
-          callContext.procRef, intrinsic, converter))
+  if (intrinsic && Fortran::lower::intrinsicRequiresCustomOptionalHandling(
+                       callContext.procRef, *intrinsic, converter))
     TODO(loc, "special cases of intrinsic with optional arguments");
 
   PreparedActualArguments loweredActuals;
   const fir::IntrinsicArgumentLoweringRules *argLowering =
-      fir::getIntrinsicArgumentLowering(intrinsic.name);
+      fir::getIntrinsicArgumentLowering(callContext.getProcedureName());
   for (const auto &arg : llvm::enumerate(callContext.procRef.arguments())) {
     auto *expr =
         Fortran::evaluate::UnwrapExpr<Fortran::lower::SomeExpr>(arg.value());
     if (!expr) {
       // Absent optional.
       loweredActuals.push_back(std::nullopt);
       continue;
     }
genIntrinsicRef(const Fortran::evaluate::SpecificIntrinsic *intrinsic,
   return result;
 }
 
 /// Main entry point to lower procedure references, regardless of what they are.
 static std::optional<hlfir::EntityWithAttributes>
 genProcedureRef(CallContext &callContext) {
   mlir::Location loc = callContext.loc;
   if (auto *intrinsic = callContext.procRef.proc().GetSpecificIntrinsic())
-    return genIntrinsicRef(*intrinsic, callContext);
+    return genIntrinsicRef(intrinsic, callContext);
+  if (Fortran::lower::isIntrinsicModuleProcRef(callContext.procRef))
+    return genIntrinsicRef(nullptr, callContext);
 
   if (callContext.isStatementFunctionCall())
     return genStmtFunctionRef(loc, callContext.converter, callContext.symMap,
                               callContext.stmtCtx, callContext.procRef);
 
   Fortran::lower::CallerInterface caller(callContext.procRef,
                                          callContext.converter);
   mlir::FunctionType callSiteType = caller.genFunctionType();
if (const Fortran::semantics::Symbol *procSym =
             callContext.procRef.proc().GetSymbol())
       isImpure = !Fortran::semantics::IsPureProcedure(*procSym);
     return ElementalUserCallBuilder{caller, callSiteType}.genElementalCall(
         loweredActuals, isImpure, callContext);
   }
   return genUserCall(loweredActuals, caller, callSiteType, callContext);
 }
 
+bool Fortran::lower::isIntrinsicModuleProcRef(
+    const Fortran::evaluate::ProcedureRef &procRef) {
+  const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol();
+  if (!symbol)
+    return false;
+  const Fortran::semantics::Symbol *module =
+      symbol->GetUltimate().owner().GetSymbol();
+  return module && module->attrs().test(Fortran::semantics::Attr::INTRINSIC) &&
+         module->name().ToString().find("omp_lib") == std::string::npos;
+}
+
 std::optional<hlfir::EntityWithAttributes> Fortran::lower::convertCallToHLFIR(
     mlir::Location loc, Fortran::lower::AbstractConverter &converter,
     const evaluate::ProcedureRef &procRef, std::optional<mlir::Type> resultType,
     Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx) {
   CallContext callContext(procRef, resultType, loc, converter, symMap, stmtCtx);
   return genProcedureRef(callContext);
 }

flang/lib/Lower/ConvertExpr.cpp

 }
 
 // Helper to get the ultimate last symbol.
 template <typename A>
 const Fortran::semantics::Symbol &getLastSym(const A &obj) {
   return obj.GetLastSymbol().GetUltimate();
 }
 
-static bool
-isIntrinsicModuleProcRef(const Fortran::evaluate::ProcedureRef &procRef) {
-  const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol();
-  if (!symbol)
-    return false;
-  const Fortran::semantics::Symbol *module =
-      symbol->GetUltimate().owner().GetSymbol();
-  return module && module->attrs().test(Fortran::semantics::Attr::INTRINSIC) &&
-         module->name().ToString().find("omp_lib") == std::string::npos;
-}
-
 // Return true if TRANSPOSE should be lowered without a runtime call.
 static bool
 isTransposeOptEnabled(const Fortran::lower::AbstractConverter &converter) {
   return optimizeTranspose &&
          converter.getLoweringOptions().getOptimizeTranspose();
 }
 
 // A set of visitors to detect if the given expression
ExtValue genRawProcedureRef(const Fortran::evaluate::ProcedureRef &procRef,
     if (isElementalProcWithArrayArgs(procRef))
       fir::emitFatalError(loc, "trying to lower elemental procedure with array "
                                "arguments as normal procedure");
 
     if (const Fortran::evaluate::SpecificIntrinsic *intrinsic =
             procRef.proc().GetSpecificIntrinsic())
       return genIntrinsicRef(procRef, resultType, *intrinsic);
 
-    if (isIntrinsicModuleProcRef(procRef))
+    if (Fortran::lower::isIntrinsicModuleProcRef(procRef))
       return genIntrinsicRef(procRef, resultType);
 
     if (isStatementFunctionCall(procRef))
       return genStmtFunctionRef(procRef);
 
     Fortran::lower::CallerInterface caller(procRef, converter);
     using PassBy = Fortran::lower::CallerInterface::PassEntityBy;
 
if (procRef.IsElemental()) {
         // according to 15.8.3 p1.
         if (!retTy)
           setUnordered(false);
 
         // Elemental intrinsic call.
         // The intrinsic procedure is called once per element of the array.
         return genElementalIntrinsicProcRef(procRef, retTy, *intrin);
       }
-      if (isIntrinsicModuleProcRef(procRef))
+      if (Fortran::lower::isIntrinsicModuleProcRef(procRef))
         return genElementalIntrinsicProcRef(procRef, retTy);
       if (ScalarExprLowering::isStatementFunctionCall(procRef))
         fir::emitFatalError(loc, "statement function cannot be elemental");
 
       // Elemental call.
       // The procedure is called once per element of the array argument(s).
       return genElementalUserDefinedProcRef(procRef, retTy);
     }

flang/test/Lower/HLFIR/intrinsic-module-procedures.f90

+! Test lowering of intrinsic module procedures to HLFIR. This
+! test is not meant to test every intrinsic module procedure,
+! it only tests that the HFLIR procedure reference lowering
+! infrastructure properly detects and dispatches intrinsic module
+! procedure calls.
+! RUN: bbc -emit-fir -hlfir -o - %s | FileCheck %s
+
+subroutine foo(cptr, x)
+  use iso_c_binding, only : c_ptr, c_loc
+  type(c_ptr) :: cptr
+  integer :: x
+  cptr = c_loc(x)
+end subroutine
+! CHECK-LABEL: func.func @_QPfoo(
+! CHECK:         %[[VAL_3:.*]]:2 = hlfir.declare {{.*}}Ecptr"
+! CHECK:         %[[VAL_3:.*]]:2 = hlfir.declare {{.*}}Ex"
+! CHECK:         %[[VAL_4:.*]] = fir.embox %[[VAL_3]]#1 : (!fir.ref<i32>) -> !fir.box<i32>
+! CHECK:         %[[VAL_5:.*]] = fir.alloca !fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>
+! CHECK:         %[[VAL_6:.*]] = fir.field_index __address, !fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>
+! CHECK:         %[[VAL_7:.*]] = fir.coordinate_of %[[VAL_5]], %[[VAL_6]] : (!fir.ref<!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>>, !fir.field) -> !fir.ref<i64>
+! CHECK:         %[[VAL_8:.*]] = fir.box_addr %[[VAL_4]] : (!fir.box<i32>) -> !fir.ref<i32>
+! CHECK:         %[[VAL_9:.*]] = fir.convert %[[VAL_8]] : (!fir.ref<i32>) -> i64
+! CHECK:         fir.store %[[VAL_9]] to %[[VAL_7]] : !fir.ref<i64>