[flang] Support lowering of intrinsic module procedure C_FUNLOC

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.

Reviewed By: jeanPerier, clementval

Differential Revision: https://reviews.llvm.org/D132273

diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp
index 0df629e..41930cc 100644 (file)
--- a/flang/lib/Lower/ConvertExpr.cpp
+++ b/flang/lib/Lower/ConvertExpr.cpp
@@ -2186,6 +2186,12 @@ public:
   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),

diff --git a/flang/lib/Lower/IntrinsicCall.cpp b/flang/lib/Lower/IntrinsicCall.cpp
index a3aeeae..a8ebe10 100644 (file)
--- a/flang/lib/Lower/IntrinsicCall.cpp
+++ b/flang/lib/Lower/IntrinsicCall.cpp
@@ -480,6 +480,7 @@ struct IntrinsicLibrary {
   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>);
@@ -724,6 +725,7 @@ static constexpr IntrinsicHandler handlers[]{
     {"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},
@@ -2468,20 +2470,29 @@ mlir::Value IntrinsicLibrary::genBtest(mlir::Type resultType,
   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);
-  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));
+  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 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>(
@@ -2492,6 +2503,20 @@ IntrinsicLibrary::genCLoc(mlir::Type resultType,
   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) {

diff --git a/flang/test/Lower/Intrinsics/c_funloc.f90 b/flang/test/Lower/Intrinsics/c_funloc.f90
new file mode 100644 (file)
index 0000000..7faaaef
--- /dev/null
+++ b/flang/test/Lower/Intrinsics/c_funloc.f90
@@ -0,0 +1,27 @@
+! 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