[flang] Support lowering of intrinsic module procedure C_F_POINTER

[peixin]

Summary

As Fortran 2018 18.2.3.3, the intrinsic module procedure
C_F_POINTER(CPTR, FPTR [, SHAPE]) associates a data pointer with the
target of a C pointer and specify its shape. CPTR shall be a scalar of
type C_PTR, and its value is the C address or the result of a reference
to C_LOC. FPTR is one pointer, either scalar or array. SHAPE is a
rank-one integer array, and it shall be present if and only if FPTR is
an array.

C_PTR is the derived type with only one component of integer 64, and the
integer 64 component value is the address. Build the right "source"
fir::ExtendedValue based on the address and shape, and use
associateMutableBox to associate the pointer with the target of the C
pointer.

Refactor the getting the address of C_PTR to reuse the code.

[peixin]

Evaluated the end-to-end execution result using the following example.

$ cat main.f90 
program main
  use iso_c_binding
  real, pointer :: cptr, cptr2(:,:)
  real, pointer :: fptr, fptr2(:,:)
  integer :: x = 3, y = 4
  type(c_ptr) :: foo

  allocate(cptr)
  allocate(cptr2(x, y))

  cptr = 1
  cptr2 = 2

  call c_f_pointer(c_loc(cptr), fptr)
  call c_f_pointer(c_loc(cptr2), fptr2, [x, y])

  print *, "loc(FPTR) = ", c_loc(fptr)
  print *, "loc(CPTR) = ", c_loc(cptr)
  print *, "FPTR = ", fptr
  print *, "shape(FPTR2) = ", shape(fptr2)
  print *, "loc(FPTR2) = ", c_loc(fptr2)
  print *, "loc(CPTR2) = ", c_loc(cptr2)
  print *, "FPTR2 = ", fptr2
end
$ flang-new -flang-experimental-exec main.f90 && ./a.out
 loc(FPTR) =  25268896
 loc(CPTR) =  25268896
 FPTR =  1.
 shape(FPTR2) =  3 4
 loc(FPTR2) =  25268928
 loc(CPTR2) =  25268928
 FPTR2 =  2. 2. 2. 2. 2. 2. 2. 2. 2. 2. 2. 2.

[peixin]

ping

[jeanPerier]

The way you deal with the CPTR arguments looks good to me, but I think the manual pointer association does not handle all the cases properly and you should favor using fir::factory::associateMutableBox.

flang/lib/Lower/IntrinsicCall.cpp

730

asInquired would be a better choice, you would get a fir::MutableBox that represent all the Pointer cases correctly.

2480

It should not be assumed that Fortran pointers are fir.ref<fir.ptr>, it is wrong if they are not local variables. All the pointer manipulations should go through the fir::MutableBoxValue abstraction.

I think all the code below should be using associateMutableBox defined here: https://github.com/llvm/llvm-project/blob/73026a4fbf7095613df4f8c205912cfc1485ed7d/flang/include/flang/Optimizer/Builder/MutableBox.h#L56.

All the work here should be to build the right "source" fir::ExtendedValue based on cPtrAddrVal and shape.
You will also to handle the character case (and add a TODO for derived type with length parameters). The standard tells the length parameters of FPTR cannot be deferred, so you will have to get the length to build the fir::CharBoxValue/fir::CharArrayBoxValue from there.

flang/test/Lower/Intrinsics/c_f_pointer.f90

23

The lowering code will most likely not work with:

subroutine test_scalar(cptr, fptr)
  use iso_c_binding
  real, pointer :: fptr
  type(c_ptr) :: cptr

  call c_f_pointer(cptr, fptr)
end

54

With everything dealing with pointer association it is worth adding tests with characters. Both with:

subroutine test_array_character(fptr, ...)
  character(10), pointer :: fptr(:,:)
...
end subroutine

and

subroutine test_array_character(fptr, n, ...)
  character(n), pointer :: fptr(:,:)
...
end subroutine

[peixin]

Reimplement this according to @jeanPerier 's suggestions.

Refactor the getting the address of C_PTR to reuse the code of several previous patches.

[jeanPerier]

Thanks a lot @peixin, I only added a small nit to move genCPtrOrCFunptrAddr into an another header/implementation file. Otherwise looks great !

flang/include/flang/Lower/ConvertExpr.h

239 ↗

(On Diff #457545)

Can you move this helper into the Optimizer/Builder/FIRBuilder.h header into the factory namespace ? That is where all helpers generating code from MLIR data structures live. ConvertExpr.h is mainly intended to define utilities that takes an evaluate::XXX data structure and generate FIR for it.

[peixin]

Thanks @jeanPerier for the info. Move it into the Optimizer/Builder/FIRBuilder as suggested.

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>);
+  void genCFPointer(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_f_pointer",
+     &I::genCFPointer,
+     {{{"cptr", asValue},
+       {"fptr", asAddr},
+       {"shape", asAddr, handleDynamicOptional}}},
+     /*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_F_POINTER
+void IntrinsicLibrary::genCFPointer(llvm::ArrayRef<fir::ExtendedValue> args) {
+  assert(args.size() == 3);
+  // Preprocess CPTR argument
+  // Get the value of the C address or the result of a reference to C_LOC.
+  mlir::Value cPtr = fir::getBase(args[0]);
+  mlir::Type cPtrTy = fir::unwrapRefType(cPtr.getType());
+  assert(cPtrTy.isa<fir::RecordType>());
+  auto cPtrRecTy = cPtrTy.dyn_cast<fir::RecordType>();
+  assert(cPtrRecTy.getTypeList().size() == 1);
+  auto fieldName = cPtrRecTy.getTypeList()[0].first;
+  mlir::Type fieldTy = cPtrRecTy.getTypeList()[0].second;
+  auto fieldIndexType = fir::FieldType::get(cPtrTy.getContext());
+  mlir::Value field = builder.create<fir::FieldIndexOp>(
+      loc, fieldIndexType, fieldName, cPtrRecTy,
+      /*typeParams=*/mlir::ValueRange{});
+  mlir::Value cPtrAddr = builder.create<fir::CoordinateOp>(
+      loc, builder.getRefType(fieldTy), cPtr, field);
+  mlir::Value cPtrAddrVal = builder.create<fir::LoadOp>(loc, cPtrAddr);
+
+  // Handle FPTR argument
+  mlir::Value fPtr = fir::getBase(args[1]);
+  auto fPtrOp = mlir::dyn_cast_or_null<fir::LoadOp>(fPtr.getDefiningOp());
+  assert(fPtrOp && "expected load of pointer for FPTR argument in C_F_POINTER");
+  mlir::Value fPtrAddr = fPtrOp.getMemref();
+  mlir::Type fPtrEleTy =
+      fir::unwrapSequenceType(fir::dyn_cast_ptrOrBoxEleTy(fPtr.getType()));
+
+  if (isStaticallyAbsent(args[2])) {
+    // CPTR and FPTR arguments must be scalar if SHAPE argument is absent.
+    mlir::Value cPtrCastTo = builder.createConvert(
+        loc, fir::PointerType::get(fPtrEleTy), cPtrAddrVal);
+    // Associate the FPTR (scalar pointer) with CPTR.
+    builder.create<fir::StoreOp>(loc, cPtrCastTo, fPtrAddr);
+  } else {
+    // Create the ShapeOp and get the shape info.
+    mlir::Value shape = fir::getBase(args[2]);
+    mlir::Type shapeArrTy = fir::unwrapRefType(shape.getType());
+    auto arrayRank = shapeArrTy.cast<fir::SequenceType>().getShape()[0];
+    assert(arrayRank > 0 && arrayRank <= 15 &&
+           "The rank of array must have been known and in range 1-15");
+    llvm::SmallVector<mlir::Value> idxShape;
+    for (int i = 0; i < (int)arrayRank; ++i) {
+      mlir::Value index =
+          builder.createIntegerConstant(loc, builder.getIntegerType(32), i);
+      mlir::Value var = builder.create<fir::CoordinateOp>(
+          loc, builder.getRefType(fir::unwrapSequenceType(shapeArrTy)), shape,
+          index);
+      mlir::Value load = builder.create<fir::LoadOp>(loc, var);
+      idxShape.push_back(
+          builder.createConvert(loc, builder.getIndexType(), load));
+    }
+    auto shapeTy = fir::ShapeType::get(builder.getContext(), arrayRank);
+    mlir::Value shapeOp = builder.create<fir::ShapeOp>(loc, shapeTy, idxShape);
+    // Embox CPTR argument of casting to pointer array in one box.
+    auto arrPtrTy =
+        fir::PointerType::get(fir::SequenceType::get(fPtrEleTy, arrayRank));
+    mlir::Value cPtrCastTo = builder.createConvert(loc, arrPtrTy, cPtrAddrVal);
+    auto cPtrAddrBox = builder.create<fir::EmboxOp>(
+        loc, fir::BoxType::get(arrPtrTy), cPtrCastTo, shapeOp);
+    // Associate the FPTR (array pointer) with CPTR.
+    builder.create<fir::StoreOp>(loc, cPtrAddrBox, fPtrAddr);
+  }
+}
+
 // C_LOC
 fir::ExtendedValue
 IntrinsicLibrary::genCLoc(mlir::Type resultType,
                           llvm::ArrayRef<fir::ExtendedValue> args) {
   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;

flang/test/Lower/Intrinsics/c_f_pointer.f90

+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+! RUN: %flang_fc1 -emit-fir %s -o - | FileCheck %s
+
+! Test intrinsic module procedure c_f_pointer
+
+! CHECK-LABEL: func.func @_QPtest_scalar(
+! CHECK-SAME:                            %[[VAL_0:.*]]: !fir.ref<!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>> {fir.bindc_name = "cptr"}) {
+! CHECK:         %[[VAL_2:.*]] = fir.alloca !fir.ptr<f32> {uniq_name = "_QFtest_scalarEfptr.addr"}
+! CHECK:         %[[VAL_4:.*]] = fir.field_index __address, !fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>
+! CHECK:         %[[VAL_5:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_4]] : (!fir.ref<!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>>, !fir.field) -> !fir.ref<i64>
+! CHECK:         %[[VAL_6:.*]] = fir.load %[[VAL_5]] : !fir.ref<i64>
+! CHECK:         %[[VAL_7:.*]] = fir.convert %[[VAL_6]] : (i64) -> !fir.ptr<f32>
+! CHECK:         fir.store %[[VAL_7]] to %[[VAL_2]] : !fir.ref<!fir.ptr<f32>>
+! CHECK:         return
+! CHECK:       }
+
+subroutine test_scalar(cptr)
+  use iso_c_binding
+  real, pointer :: fptr
+  type(c_ptr) :: cptr
+
+  call c_f_pointer(cptr, fptr)
+end
+
+! CHECK-LABEL: func.func @_QPtest_array(
+! CHECK-SAME:                           %[[VAL_0:.*]]: !fir.ref<!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>> {fir.bindc_name = "cptr"}) {
+! CHECK:         %[[VAL_1:.*]] = fir.alloca !fir.box<!fir.ptr<!fir.array<?x?xf32>>> {bindc_name = "fptr", uniq_name = "_QFtest_arrayEfptr"}
+! CHECK:         %[[SHAPE_ARRAY:.*]] = fir.allocmem !fir.array<2xi32>
+! CHECK:         %[[VAL_3:.*]] = fir.field_index __address, !fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>
+! CHECK:         %[[VAL_4:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_3]] : (!fir.ref<!fir.type<_QM__fortran_builtinsT__builtin_c_ptr{__address:i64}>>, !fir.field) -> !fir.ref<i64>
+! CHECK:         %[[VAL_5:.*]] = fir.load %[[VAL_4]] : !fir.ref<i64>
+! CHECK:         %[[VAL_6:.*]] = arith.constant 0 : i32
+! CHECK:         %[[VAL_7:.*]] = fir.coordinate_of %[[SHAPE_ARRAY:.*]], %[[VAL_6]] : (!fir.heap<!fir.array<2xi32>>, i32) -> !fir.ref<i32>
+! CHECK:         %[[VAL_8:.*]] = fir.load %[[VAL_7]] : !fir.ref<i32>
+! CHECK:         %[[VAL_9:.*]] = fir.convert %[[VAL_8]] : (i32) -> index
+! CHECK:         %[[VAL_10:.*]] = arith.constant 1 : i32
+! CHECK:         %[[VAL_11:.*]] = fir.coordinate_of %[[SHAPE_ARRAY:.*]], %[[VAL_10]] : (!fir.heap<!fir.array<2xi32>>, i32) -> !fir.ref<i32>
+! CHECK:         %[[VAL_12:.*]] = fir.load %[[VAL_11]] : !fir.ref<i32>
+! CHECK:         %[[VAL_13:.*]] = fir.convert %[[VAL_12]] : (i32) -> index
+! CHECK:         %[[VAL_14:.*]] = fir.shape %[[VAL_9]], %[[VAL_13]] : (index, index) -> !fir.shape<2>
+! CHECK:         %[[VAL_15:.*]] = fir.convert %[[VAL_5]] : (i64) -> !fir.ptr<!fir.array<?x?xf32>>
+! CHECK:         %[[VAL_16:.*]] = fir.embox %[[VAL_15]](%[[VAL_14]]) : (!fir.ptr<!fir.array<?x?xf32>>, !fir.shape<2>) -> !fir.box<!fir.ptr<!fir.array<?x?xf32>>>
+! CHECK:         fir.store %[[VAL_16]] to %[[VAL_1]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>
+! CHECK:         fir.freemem %[[SHAPE_ARRAY]] : !fir.heap<!fir.array<2xi32>>
+! CHECK:         return
+! CHECK:       }
+
+subroutine test_array(cptr)
+  use iso_c_binding
+  real, pointer :: fptr(:,:)
+  type(c_ptr) :: cptr
+  integer :: x = 3, y = 4
+
+  call c_f_pointer(cptr, fptr, [x, y])
+end