[flang] Support lowering of intrinsic module procedure C_FUNLOC

[peixin]

Summary

As Fortran 2018 18.2.3.5, the intrinsic c_funloc(x) gets the C address
of argument x. It returns the scalar of type C_FUNPTR. As defined in
iso_c_binding in flang/module/__fortran_builtins.f90, C_FUNPTR is the
derived type with only one component of integer 64.

This follows the implementation of https://reviews.llvm.org/D129659. The
argument is lowered as ProcBox and the address is generated using
fir.box_addr.

[peixin]

@klausler I saw you added the definition of the c_funloc in iso_c_binding using an unknown function loc https://github.com/llvm/llvm-project/blob/e0f64b319e65b9788c424c00bf7f16a8a78acb15/flang/module/iso_c_binding.f90#L117-L121. Should it be removed if with this support?

[peixin]

ping

[clementval]

LGTM

flang/lib/Lower/ConvertExpr.cpp

#define GENBIN(GenBinEvOp, GenBinTyCat, GenBinFirOp)                           \
   }
 
   /// Helper to lower intrinsic arguments to a fir::BoxValue.
   /// It preserves all the non default lower bounds/non deferred length
   /// parameter information.
   ExtValue lowerIntrinsicArgumentAsBox(const Fortran::lower::SomeExpr &expr) {
     mlir::Location loc = getLoc();
     ExtValue exv = genBoxArg(expr);
+    auto exvTy = fir::getBase(exv).getType();
+    if (exvTy.isa<mlir::FunctionType>()) {
+      auto boxProcTy = builder.getBoxProcType(exvTy.cast<mlir::FunctionType>());
+      return builder.create<fir::EmboxProcOp>(loc, boxProcTy,
+                                              fir::getBase(exv));
+    }
     mlir::Value box = builder.createBox(loc, exv);
     return fir::BoxValue(
         box, fir::factory::getNonDefaultLowerBounds(builder, loc, exv),
         fir::factory::getNonDeferredLenParams(exv));
   }
 
   /// Generate a call to a Fortran intrinsic or intrinsic module procedure.
   ExtValue genIntrinsicRef(

flang/lib/Lower/IntrinsicCall.cpp

struct IntrinsicLibrary {
   template <mlir::arith::CmpIPredicate pred>
   fir::ExtendedValue genCharacterCompare(mlir::Type,
                                          llvm::ArrayRef<fir::ExtendedValue>);
   mlir::Value genCmplx(mlir::Type, llvm::ArrayRef<mlir::Value>);
   mlir::Value genConjg(mlir::Type, llvm::ArrayRef<mlir::Value>);
   fir::ExtendedValue genCount(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   void genCpuTime(llvm::ArrayRef<fir::ExtendedValue>);
   fir::ExtendedValue genCshift(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
+  fir::ExtendedValue genCFunLoc(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   fir::ExtendedValue genCLoc(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   void genDateAndTime(llvm::ArrayRef<fir::ExtendedValue>);
   mlir::Value genDim(mlir::Type, llvm::ArrayRef<mlir::Value>);
   fir::ExtendedValue genDotProduct(mlir::Type,
                                    llvm::ArrayRef<fir::ExtendedValue>);
   mlir::Value genDprod(mlir::Type, llvm::ArrayRef<mlir::Value>);
   mlir::Value genDshiftl(mlir::Type, llvm::ArrayRef<mlir::Value>);
   mlir::Value genDshiftr(mlir::Type, llvm::ArrayRef<mlir::Value>);
static constexpr IntrinsicHandler handlers[]{
      &I::genAssociated,
      {{{"pointer", asInquired}, {"target", asInquired}}},
      /*isElemental=*/false},
     {"bge", &I::genBitwiseCompare<mlir::arith::CmpIPredicate::uge>},
     {"bgt", &I::genBitwiseCompare<mlir::arith::CmpIPredicate::ugt>},
     {"ble", &I::genBitwiseCompare<mlir::arith::CmpIPredicate::ule>},
     {"blt", &I::genBitwiseCompare<mlir::arith::CmpIPredicate::ult>},
     {"btest", &I::genBtest},
+    {"c_funloc", &I::genCFunLoc, {{{"x", asBox}}}, /*isElemental=*/false},
     {"c_loc", &I::genCLoc, {{{"x", asBox}}}, /*isElemental=*/false},
     {"ceiling", &I::genCeiling},
     {"char", &I::genChar},
     {"cmplx",
      &I::genCmplx,
      {{{"x", asValue}, {"y", asValue, handleDynamicOptional}}}},
     {"command_argument_count", &I::genCommandArgumentCount},
     {"conjg", &I::genConjg},
mlir::Value IntrinsicLibrary::genBtest(mlir::Type resultType,
   mlir::Type argType = args[0].getType();
   mlir::Value pos = builder.createConvert(loc, argType, args[1]);
   auto shift = builder.create<mlir::arith::ShRUIOp>(loc, args[0], pos);
   mlir::Value one = builder.createIntegerConstant(loc, argType, 1);
   auto res = builder.create<mlir::arith::AndIOp>(loc, shift, one);
   return builder.createConvert(loc, resultType, res);
 }
 
-// C_LOC
-fir::ExtendedValue
-IntrinsicLibrary::genCLoc(mlir::Type resultType,
-                          llvm::ArrayRef<fir::ExtendedValue> args) {
+static fir::ExtendedValue
+genCLocOrCFunLoc(fir::FirOpBuilder &builder, mlir::Location loc,
+                 mlir::Type resultType, llvm::ArrayRef<fir::ExtendedValue> args,
+                 bool isFunc = false) {
   assert(args.size() == 1 && resultType.isa<fir::RecordType>());
   auto resTy = resultType.dyn_cast<fir::RecordType>();
   assert(resTy.getTypeList().size() == 1);
   auto fieldName = resTy.getTypeList()[0].first;
   auto fieldTy = resTy.getTypeList()[0].second;
   mlir::Value res = builder.create<fir::AllocaOp>(loc, resultType);
+  mlir::Value argAddr;
+  if (isFunc) {
+    mlir::Value argValue = fir::getBase(args[0]);
+    assert(argValue.getType().isa<fir::BoxProcType>() &&
+           "c_funloc argument must have been lowered to a fir.boxproc");
+    auto funcTy = argValue.getType().cast<fir::BoxProcType>().getEleTy();
+    argAddr = builder.create<fir::BoxAddrOp>(loc, funcTy, argValue);
+  } else {
     const auto *box = args[0].getBoxOf<fir::BoxValue>();
-  assert(box && "c_loc argument must have been lowered to a fix.box");
-  mlir::Value argAddr =
-      builder.create<fir::BoxAddrOp>(loc, box->getMemTy(), fir::getBase(*box));
+    assert(box && "c_loc argument must have been lowered to a fir.box");
+    argAddr = builder.create<fir::BoxAddrOp>(loc, box->getMemTy(),
+                                             fir::getBase(*box));
+  }
   mlir::Value argAddrVal = builder.createConvert(loc, fieldTy, argAddr);
   auto fieldIndexType = fir::FieldType::get(resultType.getContext());
   mlir::Value field = builder.create<fir::FieldIndexOp>(
       loc, fieldIndexType, fieldName, resTy, /*typeParams=*/mlir::ValueRange{});
   mlir::Value resAddr = builder.create<fir::CoordinateOp>(
       loc, builder.getRefType(fieldTy), res, field);
   builder.create<fir::StoreOp>(loc, argAddrVal, resAddr);
   return res;
 }
 
+// C_FUNLOC
+fir::ExtendedValue
+IntrinsicLibrary::genCFunLoc(mlir::Type resultType,
+                             llvm::ArrayRef<fir::ExtendedValue> args) {
+  return genCLocOrCFunLoc(builder, loc, resultType, args, /*isFunc=*/true);
+}
+
+// C_LOC
+fir::ExtendedValue
+IntrinsicLibrary::genCLoc(mlir::Type resultType,
+                          llvm::ArrayRef<fir::ExtendedValue> args) {
+  return genCLocOrCFunLoc(builder, loc, resultType, args);
+}
+
 // CEILING
 mlir::Value IntrinsicLibrary::genCeiling(mlir::Type resultType,
                                          llvm::ArrayRef<mlir::Value> args) {
   // Optional KIND argument.
   assert(args.size() >= 1);
   mlir::Value arg = args[0];
   // Use ceil that is not an actual Fortran intrinsic but that is
   // an llvm intrinsic that does the same, but return a floating

flang/test/Lower/Intrinsics/c_funloc.f90

+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+! RUN: %flang_fc1 -emit-fir %s -o - | FileCheck %s
+
+! Test intrinsic module procedure c_funloc
+
+! CHECK-LABEL: func.func @_QPtest() {
+! CHECK:         %[[VAL_1:.*]] = fir.address_of(@_QPfoo) : (!fir.ref<i32>) -> ()
+! CHECK:         %[[VAL_2:.*]] = fir.emboxproc %[[VAL_1]] : ((!fir.ref<i32>) -> ()) -> !fir.boxproc<(!fir.ref<i32>) -> ()>
+! CHECK:         %[[VAL_3:.*]] = fir.alloca !fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>
+! CHECK:         %[[VAL_4:.*]] = fir.box_addr %[[VAL_2]] : (!fir.boxproc<(!fir.ref<i32>) -> ()>) -> ((!fir.ref<i32>) -> ())
+! CHECK:         %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : ((!fir.ref<i32>) -> ()) -> i64
+! CHECK:         %[[VAL_6:.*]] = fir.field_index __address, !fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>
+! CHECK:         %[[VAL_7:.*]] = fir.coordinate_of %[[VAL_3]], %[[VAL_6]] : (!fir.ref<!fir.type<_QM__fortran_builtinsT__builtin_c_funptr{__address:i64}>>, !fir.field) -> !fir.ref<i64>
+! CHECK:         fir.store %[[VAL_5]] to %[[VAL_7]] : !fir.ref<i64>
+
+subroutine test()
+  use iso_c_binding
+  interface
+    subroutine foo(i)
+      integer :: i
+    end
+  end interface
+
+  type(c_funptr) :: tmp_cptr
+
+  tmp_cptr = c_funloc(foo)
+end