Skip to content

Commit bd8bec2

Browse files
DanielCChenDanielCChen
authored
[Flang] Support NULL(procptr): null intrinsic that has procedure pointer argument. (#80072)
This PR adds support for NULL intrinsic to have a procedure pointer argument.
1 parent 5c2da28 commit bd8bec2

File tree

4 files changed

+52
-4
lines changed

4 files changed

+52
-4
lines changed

‎flang/lib/Lower/Bridge.cpp

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -3273,7 +3273,9 @@ class FirConverter : public Fortran::lower::AbstractConverter {
32733273
if (Fortran::evaluate::IsProcedurePointer(assign.lhs)) {
32743274
hlfir::Entity lhs = Fortran::lower::convertExprToHLFIR(
32753275
loc, *this, assign.lhs, localSymbols, stmtCtx);
3276-
if (Fortran::evaluate::IsNullProcedurePointer(assign.rhs)) {
3276+
if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
3277+
assign.rhs)) {
3278+
// rhs is null(). rhs being null(pptr) is handled in genNull.
32773279
auto boxTy{Fortran::lower::getUntypedBoxProcType(&getMLIRContext())};
32783280
hlfir::Entity rhs(
32793281
fir::factory::createNullBoxProc(*builder, loc, boxTy));

‎flang/lib/Lower/CallInterface.cpp

Lines changed: 7 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -788,9 +788,13 @@ class Fortran::lower::CallInterfaceImpl {
788788
void handleImplicitResult(
789789
const Fortran::evaluate::characteristics::FunctionResult &result,
790790
bool isBindC) {
791-
if (result.IsProcedurePointer())
792-
TODO(interface.converter.getCurrentLocation(),
793-
"procedure pointer result not yet handled");
791+
if (auto proc{result.IsProcedurePointer()}) {
792+
mlir::Type mlirType = fir::BoxProcType::get(
793+
&mlirContext, getProcedureType(*proc, interface.converter));
794+
addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,
795+
Property::Value);
796+
return;
797+
}
794798
const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape =
795799
result.GetTypeAndShape();
796800
assert(typeAndShape && "expect type for non proc pointer result");

‎flang/lib/Optimizer/Builder/IntrinsicCall.cpp

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -5173,6 +5173,15 @@ IntrinsicLibrary::genNull(mlir::Type, llvm::ArrayRef<fir::ExtendedValue> args) {
51735173
// (see table 16.5 of Fortran 2018 standard).
51745174
assert(args.size() == 1 && isStaticallyPresent(args[0]) &&
51755175
"MOLD argument required to lower NULL outside of any context");
5176+
mlir::Type ptrTy = fir::getBase(args[0]).getType();
5177+
if (ptrTy && fir::isBoxProcAddressType(ptrTy)) {
5178+
auto boxProcType = mlir::cast<fir::BoxProcType>(fir::unwrapRefType(ptrTy));
5179+
mlir::Value boxStorage = builder.createTemporary(loc, boxProcType);
5180+
mlir::Value nullBoxProc =
5181+
fir::factory::createNullBoxProc(builder, loc, boxProcType);
5182+
builder.createStoreWithConvert(loc, nullBoxProc, boxStorage);
5183+
return boxStorage;
5184+
}
51765185
const auto *mold = args[0].getBoxOf<fir::MutableBoxValue>();
51775186
assert(mold && "MOLD must be a pointer or allocatable");
51785187
fir::BaseBoxType boxType = mold->getBoxTy();

‎flang/test/Lower/HLFIR/procedure-pointer.f90

Lines changed: 33 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -307,6 +307,39 @@ function reffunc(arg) result(pp)
307307
! CHECK: return
308308
end
309309

310+
subroutine sub12()
311+
use m
312+
procedure(char_func), pointer :: p1, p2
313+
! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>
314+
! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>
315+
! CHECK: %[[VAL_2:.*]] = fir.alloca !fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>> {bindc_name = "p1", uniq_name = "_QFsub12Ep1"}
316+
! CHECK: %[[VAL_3:.*]] = fir.zero_bits (!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>
317+
! CHECK: %[[VAL_4:.*]] = fir.emboxproc %[[VAL_3]] : ((!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>) -> !fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>
318+
! CHECK: fir.store %[[VAL_4]] to %[[VAL_2]] : !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>
319+
! CHECK: %[[VAL_5:.*]]:2 = hlfir.declare %[[VAL_2]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFsub12Ep1"} : (!fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>) -> (!fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>, !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>)
320+
! CHECK: %[[VAL_6:.*]] = fir.alloca !fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>> {bindc_name = "p2", uniq_name = "_QFsub12Ep2"}
321+
! CHECK: %[[VAL_7:.*]] = fir.zero_bits (!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>
322+
! CHECK: %[[VAL_8:.*]] = fir.emboxproc %[[VAL_7]] : ((!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>) -> !fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>
323+
! CHECK: fir.store %[[VAL_8]] to %[[VAL_6]] : !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>
324+
! CHECK: %[[VAL_9:.*]]:2 = hlfir.declare %[[VAL_6]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFsub12Ep2"} : (!fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>) -> (!fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>, !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>)
325+
326+
p1 => NULL(p2)
327+
! CHECK: %[[VAL_10:.*]] = fir.zero_bits (!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>
328+
! CHECK: %[[VAL_11:.*]] = fir.emboxproc %[[VAL_10]] : ((!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>) -> !fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>
329+
! CHECK: fir.store %[[VAL_11]] to %[[VAL_1]] : !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>
330+
! CHECK: %[[VAL_12:.*]]:2 = hlfir.declare %[[VAL_1]] {uniq_name = ".tmp.intrinsic_result"} : (!fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>) -> (!fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>, !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>)
331+
! CHECK: %[[VAL_13:.*]] = fir.load %[[VAL_12]]#0 : !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>
332+
! CHECK: fir.store %[[VAL_13]] to %[[VAL_5]]#0 : !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>
333+
334+
call foo2(NULL(p2))
335+
! CHECK: %[[VAL_14:.*]] = fir.zero_bits (!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>
336+
! CHECK: %[[VAL_15:.*]] = fir.emboxproc %[[VAL_14]] : ((!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>) -> !fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>
337+
! CHECK: fir.store %[[VAL_15]] to %[[VAL_0]] : !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>
338+
! CHECK: %[[VAL_16:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = ".tmp.intrinsic_result"} : (!fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>) -> (!fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>, !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>)
339+
! CHECK: %[[VAL_17:.*]] = fir.convert %[[VAL_16]]#0 : (!fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>) -> !fir.ref<!fir.boxproc<() -> ()>>
340+
! CHECK: fir.call @_QPfoo2(%[[VAL_17]]) fastmath<contract> : (!fir.ref<!fir.boxproc<() -> ()>>) -> ()
341+
end
342+
310343
! CHECK-LABEL: fir.global internal @_QFsub1Ep2 : !fir.boxproc<(!fir.ref<f32>) -> f32> {
311344
! CHECK: %[[VAL_0:.*]] = fir.zero_bits (!fir.ref<f32>) -> f32
312345
! CHECK: %[[VAL_1:.*]] = fir.emboxproc %[[VAL_0]] : ((!fir.ref<f32>) -> f32) -> !fir.boxproc<(!fir.ref<f32>) -> f32>

0 commit comments

Comments
 (0)