Index: flang/lib/Lower/IntrinsicCall.cpp =================================================================== --- flang/lib/Lower/IntrinsicCall.cpp +++ flang/lib/Lower/IntrinsicCall.cpp @@ -480,6 +480,7 @@ fir::ExtendedValue genCount(mlir::Type, llvm::ArrayRef); void genCpuTime(llvm::ArrayRef); fir::ExtendedValue genCshift(mlir::Type, llvm::ArrayRef); + void genCFPointer(llvm::ArrayRef); fir::ExtendedValue genCLoc(mlir::Type, llvm::ArrayRef); void genDateAndTime(llvm::ArrayRef); mlir::Value genDim(mlir::Type, llvm::ArrayRef); @@ -723,6 +724,12 @@ {"ble", &I::genBitwiseCompare}, {"blt", &I::genBitwiseCompare}, {"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}, @@ -2448,6 +2455,71 @@ return builder.createConvert(loc, resultType, res); } +// C_F_POINTER +void IntrinsicLibrary::genCFPointer(llvm::ArrayRef 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()); + auto cPtrRecTy = cPtrTy.dyn_cast(); + 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( + loc, fieldIndexType, fieldName, cPtrRecTy, + /*typeParams=*/mlir::ValueRange{}); + mlir::Value cPtrAddr = builder.create( + loc, builder.getRefType(fieldTy), cPtr, field); + mlir::Value cPtrAddrVal = builder.create(loc, cPtrAddr); + + // Handle FPTR argument + mlir::Value fPtr = fir::getBase(args[1]); + auto fPtrOp = mlir::dyn_cast_or_null(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(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().getShape()[0]; + assert(arrayRank > 0 && arrayRank <= 15 && + "The rank of array must have been known and in range 1-15"); + llvm::SmallVector idxShape; + for (int i = 0; i < (int)arrayRank; ++i) { + mlir::Value index = + builder.createIntegerConstant(loc, builder.getIntegerType(32), i); + mlir::Value var = builder.create( + loc, builder.getRefType(fir::unwrapSequenceType(shapeArrTy)), shape, + index); + mlir::Value load = builder.create(loc, var); + idxShape.push_back( + builder.createConvert(loc, builder.getIndexType(), load)); + } + auto shapeTy = fir::ShapeType::get(builder.getContext(), arrayRank); + mlir::Value shapeOp = builder.create(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( + loc, fir::BoxType::get(arrPtrTy), cPtrCastTo, shapeOp); + // Associate the FPTR (array pointer) with CPTR. + builder.create(loc, cPtrAddrBox, fPtrAddr); + } +} + // C_LOC fir::ExtendedValue IntrinsicLibrary::genCLoc(mlir::Type resultType, Index: flang/test/Lower/Intrinsics/c_f_pointer.f90 =================================================================== --- /dev/null +++ flang/test/Lower/Intrinsics/c_f_pointer.f90 @@ -0,0 +1,55 @@ +! 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.bindc_name = "cptr"}) { +! CHECK: %[[VAL_2:.*]] = fir.alloca !fir.ptr {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.field) -> !fir.ref +! CHECK: %[[VAL_6:.*]] = fir.load %[[VAL_5]] : !fir.ref +! CHECK: %[[VAL_7:.*]] = fir.convert %[[VAL_6]] : (i64) -> !fir.ptr +! CHECK: fir.store %[[VAL_7]] to %[[VAL_2]] : !fir.ref> +! 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.bindc_name = "cptr"}) { +! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.box>> {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.field) -> !fir.ref +! CHECK: %[[VAL_5:.*]] = fir.load %[[VAL_4]] : !fir.ref +! CHECK: %[[VAL_6:.*]] = arith.constant 0 : i32 +! CHECK: %[[VAL_7:.*]] = fir.coordinate_of %[[SHAPE_ARRAY:.*]], %[[VAL_6]] : (!fir.heap>, i32) -> !fir.ref +! CHECK: %[[VAL_8:.*]] = fir.load %[[VAL_7]] : !fir.ref +! 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>, i32) -> !fir.ref +! CHECK: %[[VAL_12:.*]] = fir.load %[[VAL_11]] : !fir.ref +! 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> +! CHECK: %[[VAL_16:.*]] = fir.embox %[[VAL_15]](%[[VAL_14]]) : (!fir.ptr>, !fir.shape<2>) -> !fir.box>> +! CHECK: fir.store %[[VAL_16]] to %[[VAL_1]] : !fir.ref>>> +! CHECK: fir.freemem %[[SHAPE_ARRAY]] : !fir.heap> +! 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