diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp --- a/flang/lib/Lower/ConvertExpr.cpp +++ b/flang/lib/Lower/ConvertExpr.cpp @@ -2186,6 +2186,12 @@ ExtValue lowerIntrinsicArgumentAsBox(const Fortran::lower::SomeExpr &expr) { mlir::Location loc = getLoc(); ExtValue exv = genBoxArg(expr); + auto exvTy = fir::getBase(exv).getType(); + if (exvTy.isa()) { + auto boxProcTy = builder.getBoxProcType(exvTy.cast()); + return builder.create(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 --- a/flang/lib/Lower/IntrinsicCall.cpp +++ b/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); + fir::ExtendedValue genCFunLoc(mlir::Type, llvm::ArrayRef); fir::ExtendedValue genCLoc(mlir::Type, llvm::ArrayRef); void genDateAndTime(llvm::ArrayRef); mlir::Value genDim(mlir::Type, llvm::ArrayRef); @@ -724,6 +725,7 @@ {"ble", &I::genBitwiseCompare}, {"blt", &I::genBitwiseCompare}, {"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 @@ return builder.createConvert(loc, resultType, res); } -// C_LOC -fir::ExtendedValue -IntrinsicLibrary::genCLoc(mlir::Type resultType, - llvm::ArrayRef args) { +static fir::ExtendedValue +genCLocOrCFunLoc(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Type resultType, llvm::ArrayRef args, + bool isFunc = false) { assert(args.size() == 1 && resultType.isa()); auto resTy = resultType.dyn_cast(); assert(resTy.getTypeList().size() == 1); auto fieldName = resTy.getTypeList()[0].first; auto fieldTy = resTy.getTypeList()[0].second; mlir::Value res = builder.create(loc, resultType); - const auto *box = args[0].getBoxOf(); - assert(box && "c_loc argument must have been lowered to a fix.box"); - mlir::Value argAddr = - builder.create(loc, box->getMemTy(), fir::getBase(*box)); + mlir::Value argAddr; + if (isFunc) { + mlir::Value argValue = fir::getBase(args[0]); + assert(argValue.getType().isa() && + "c_funloc argument must have been lowered to a fir.boxproc"); + auto funcTy = argValue.getType().cast().getEleTy(); + argAddr = builder.create(loc, funcTy, argValue); + } else { + const auto *box = args[0].getBoxOf(); + assert(box && "c_loc argument must have been lowered to a fir.box"); + argAddr = builder.create(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( @@ -2492,6 +2503,20 @@ return res; } +// C_FUNLOC +fir::ExtendedValue +IntrinsicLibrary::genCFunLoc(mlir::Type resultType, + llvm::ArrayRef args) { + return genCLocOrCFunLoc(builder, loc, resultType, args, /*isFunc=*/true); +} + +// C_LOC +fir::ExtendedValue +IntrinsicLibrary::genCLoc(mlir::Type resultType, + llvm::ArrayRef args) { + return genCLocOrCFunLoc(builder, loc, resultType, args); +} + // CEILING mlir::Value IntrinsicLibrary::genCeiling(mlir::Type resultType, llvm::ArrayRef args) { diff --git a/flang/test/Lower/Intrinsics/c_funloc.f90 b/flang/test/Lower/Intrinsics/c_funloc.f90 new file mode 100644 --- /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) -> () +! CHECK: %[[VAL_2:.*]] = fir.emboxproc %[[VAL_1]] : ((!fir.ref) -> ()) -> !fir.boxproc<(!fir.ref) -> ()> +! 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) -> ()>) -> ((!fir.ref) -> ()) +! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_4]] : ((!fir.ref) -> ()) -> 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.field) -> !fir.ref +! CHECK: fir.store %[[VAL_5]] to %[[VAL_7]] : !fir.ref + +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