Skip to content

Commit cdb320b

Browse files
DanielCChenjeanPerier
DanielCChen
and
jeanPerier
authored
[Flang]: Lowering reference to functions that return a procedure pointer (#78194)
This PR adds lowering the reference to a function that returns a procedure pointer. It also fixed intrinsic ASSOCIATED to take such argument. --------- Co-authored-by: jeanPerier <[email protected]>
1 parent 223025a commit cdb320b

File tree

6 files changed

+139
-37
lines changed

6 files changed

+139
-37
lines changed

‎flang/lib/Lower/CallInterface.cpp

Lines changed: 33 additions & 32 deletions
Original file line numberDiff line numberDiff line change
@@ -371,7 +371,7 @@ bool Fortran::lower::CallerInterface::mustMapInterfaceSymbols() const {
371371
const std::optional<Fortran::evaluate::characteristics::FunctionResult>
372372
&result = characteristic->functionResult;
373373
if (!result || result->CanBeReturnedViaImplicitInterface() ||
374-
!getInterfaceDetails())
374+
!getInterfaceDetails() || result->IsProcedurePointer())
375375
return false;
376376
bool allResultSpecExprConstant = true;
377377
auto visitor = [&](const Fortran::lower::SomeExpr &e) {
@@ -1111,39 +1111,40 @@ class Fortran::lower::CallInterfaceImpl {
11111111
const Fortran::evaluate::characteristics::FunctionResult &result) {
11121112
using Attr = Fortran::evaluate::characteristics::FunctionResult::Attr;
11131113
mlir::Type mlirType;
1114-
if (auto proc{result.IsProcedurePointer()})
1114+
if (auto proc{result.IsProcedurePointer()}) {
11151115
mlirType = fir::BoxProcType::get(
11161116
&mlirContext, getProcedureType(*proc, interface.converter));
1117-
else {
1118-
const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape =
1119-
result.GetTypeAndShape();
1120-
assert(typeAndShape && "expect type for non proc pointer result");
1121-
mlirType = translateDynamicType(typeAndShape->type());
1122-
const auto *resTypeAndShape{result.GetTypeAndShape()};
1123-
bool resIsPolymorphic =
1124-
resTypeAndShape && resTypeAndShape->type().IsPolymorphic();
1125-
bool resIsAssumedType =
1126-
resTypeAndShape && resTypeAndShape->type().IsAssumedType();
1127-
if (std::optional<fir::SequenceType::Shape> bounds =
1128-
getBounds(*typeAndShape))
1129-
mlirType = fir::SequenceType::get(*bounds, mlirType);
1130-
if (result.attrs.test(Attr::Allocatable))
1131-
mlirType = fir::wrapInClassOrBoxType(
1132-
fir::HeapType::get(mlirType), resIsPolymorphic, resIsAssumedType);
1133-
if (result.attrs.test(Attr::Pointer))
1134-
mlirType =
1135-
fir::wrapInClassOrBoxType(fir::PointerType::get(mlirType),
1136-
resIsPolymorphic, resIsAssumedType);
1137-
1138-
if (fir::isa_char(mlirType)) {
1139-
// Character scalar results must be passed as arguments in lowering so
1140-
// that an assumed length character function callee can access the
1141-
// result length. A function with a result requiring an explicit
1142-
// interface does not have to be compatible with assumed length
1143-
// function, but most compilers supports it.
1144-
handleImplicitCharacterResult(typeAndShape->type());
1145-
return;
1146-
}
1117+
addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,
1118+
Property::Value);
1119+
return;
1120+
}
1121+
const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape =
1122+
result.GetTypeAndShape();
1123+
assert(typeAndShape && "expect type for non proc pointer result");
1124+
mlirType = translateDynamicType(typeAndShape->type());
1125+
const auto *resTypeAndShape{result.GetTypeAndShape()};
1126+
bool resIsPolymorphic =
1127+
resTypeAndShape && resTypeAndShape->type().IsPolymorphic();
1128+
bool resIsAssumedType =
1129+
resTypeAndShape && resTypeAndShape->type().IsAssumedType();
1130+
if (std::optional<fir::SequenceType::Shape> bounds =
1131+
getBounds(*typeAndShape))
1132+
mlirType = fir::SequenceType::get(*bounds, mlirType);
1133+
if (result.attrs.test(Attr::Allocatable))
1134+
mlirType = fir::wrapInClassOrBoxType(fir::HeapType::get(mlirType),
1135+
resIsPolymorphic, resIsAssumedType);
1136+
if (result.attrs.test(Attr::Pointer))
1137+
mlirType = fir::wrapInClassOrBoxType(fir::PointerType::get(mlirType),
1138+
resIsPolymorphic, resIsAssumedType);
1139+
1140+
if (fir::isa_char(mlirType)) {
1141+
// Character scalar results must be passed as arguments in lowering so
1142+
// that an assumed length character function callee can access the
1143+
// result length. A function with a result requiring an explicit
1144+
// interface does not have to be compatible with assumed length
1145+
// function, but most compilers supports it.
1146+
handleImplicitCharacterResult(typeAndShape->type());
1147+
return;
11471148
}
11481149

11491150
addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,

‎flang/lib/Lower/ConvertCall.cpp

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1379,6 +1379,9 @@ genUserCall(Fortran::lower::PreparedActualArguments &loweredActuals,
13791379
loc, callContext.converter, callContext.symMap, callContext.stmtCtx,
13801380
caller, callSiteType, callContext.resultType,
13811381
callContext.isElementalProcWithArrayArgs());
1382+
// For procedure pointer function result, just return the call.
1383+
if (callContext.resultType && callContext.resultType->isa<fir::BoxProcType>())
1384+
return hlfir::EntityWithAttributes(fir::getBase(result));
13821385

13831386
/// Clean-up associations and copy-in.
13841387
for (auto cleanUp : callCleanUps)

‎flang/lib/Lower/ConvertExprToHLFIR.cpp

Lines changed: 7 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1433,9 +1433,13 @@ class HlfirBuilder {
14331433
}
14341434

14351435
hlfir::EntityWithAttributes gen(const Fortran::evaluate::ProcedureRef &expr) {
1436-
TODO(
1437-
getLoc(),
1438-
"lowering function references that return procedure pointers to HLFIR");
1436+
Fortran::evaluate::ProcedureDesignator proc{expr.proc()};
1437+
auto procTy{Fortran::lower::translateSignature(proc, getConverter())};
1438+
auto result = Fortran::lower::convertCallToHLFIR(getLoc(), getConverter(),
1439+
expr, procTy.getResult(0),
1440+
getSymMap(), getStmtCtx());
1441+
assert(result.has_value());
1442+
return *result;
14391443
}
14401444

14411445
template <typename T>

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

Lines changed: 6 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -2158,9 +2158,13 @@ fir::ExtendedValue
21582158
IntrinsicLibrary::genAssociated(mlir::Type resultType,
21592159
llvm::ArrayRef<fir::ExtendedValue> args) {
21602160
assert(args.size() == 2);
2161-
if (fir::isBoxProcAddressType(fir::getBase(args[0]).getType())) {
2161+
mlir::Type ptrTy = fir::getBase(args[0]).getType();
2162+
if (ptrTy &&
2163+
(fir::isBoxProcAddressType(ptrTy) || ptrTy.isa<fir::BoxProcType>())) {
21622164
mlir::Value pointerBoxProc =
2163-
builder.create<fir::LoadOp>(loc, fir::getBase(args[0]));
2165+
fir::isBoxProcAddressType(ptrTy)
2166+
? builder.create<fir::LoadOp>(loc, fir::getBase(args[0]))
2167+
: fir::getBase(args[0]);
21642168
mlir::Value pointerTarget =
21652169
builder.create<fir::BoxAddrOp>(loc, pointerBoxProc);
21662170
if (isStaticallyAbsent(args[1]))

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

Lines changed: 62 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,7 @@
22
! 1. declaration and initialization
33
! 2. pointer assignment and invocation
44
! 3. procedure pointer argument passing.
5+
! 3. procedure pointer function result.
56
! RUN: bbc -emit-hlfir -o - %s | FileCheck %s
67

78
module m
@@ -244,6 +245,67 @@ subroutine sub9()
244245
! CHECK: fir.call @_QPfoo2(%[[VAL_10]]) fastmath<contract> : (!fir.ref<!fir.boxproc<() -> ()>>) -> ()
245246
end
246247

248+
subroutine sub10()
249+
use m
250+
251+
procedure(real_func), pointer :: p1
252+
! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.boxproc<(!fir.ref<f32>) -> f32> {bindc_name = "p1", uniq_name = "_QFsub10Ep1"}
253+
! CHECK: %[[VAL_1:.*]] = fir.zero_bits (!fir.ref<f32>) -> f32
254+
! CHECK: %[[VAL_2:.*]] = fir.emboxproc %[[VAL_1]] : ((!fir.ref<f32>) -> f32) -> !fir.boxproc<(!fir.ref<f32>) -> f32>
255+
! CHECK: fir.store %[[VAL_2]] to %[[VAL_0]] : !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
256+
! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFsub10Ep1"} : (!fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>) -> (!fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>, !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>)
257+
258+
p1 => reffunc(5)
259+
! CHECK: %c5_i32 = arith.constant 5 : i32
260+
! CHECK: %[[VAL_4:.*]]:3 = hlfir.associate %c5_i32 {adapt.valuebyref} : (i32) -> (!fir.ref<i32>, !fir.ref<i32>, i1)
261+
! CHECK: %[[VAL_5:.*]] = fir.call @_QFsub10Preffunc(%[[VAL_4]]#1) fastmath<contract> : (!fir.ref<i32>) -> !fir.boxproc<(!fir.ref<f32>) -> f32>
262+
! CHECK: fir.store %[[VAL_5]] to %[[VAL_3]]#0 : !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
263+
264+
contains
265+
function reffunc(arg) result(pp)
266+
integer :: arg
267+
procedure(real_func), pointer :: pp
268+
! CHECK: %[[VAL_0:.*]]:2 = hlfir.declare %arg0 {uniq_name = "_QFsub10FreffuncEarg"} : (!fir.ref<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
269+
! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.boxproc<(!fir.ref<f32>) -> f32> {bindc_name = "pp", uniq_name = "_QFsub10FreffuncEpp"}
270+
! CHECK: %[[VAL_2:.*]] = fir.zero_bits (!fir.ref<f32>) -> f32
271+
! CHECK: %[[VAL_3:.*]] = fir.emboxproc %[[VAL_2]] : ((!fir.ref<f32>) -> f32) -> !fir.boxproc<(!fir.ref<f32>) -> f32>
272+
! CHECK: fir.store %[[VAL_3]] to %[[VAL_1]] : !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
273+
! CHECK: %[[VAL_4:.*]]:2 = hlfir.declare %[[VAL_1]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFsub10FreffuncEpp"} : (!fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>) -> (!fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>, !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>)
274+
275+
pp => real_func
276+
! CHECK: %[[VAL_5:.*]] = fir.address_of(@_QPreal_func) : (!fir.ref<f32>) -> f32
277+
! CHECK: %[[VAL_6:.*]] = fir.emboxproc %[[VAL_5]] : ((!fir.ref<f32>) -> f32) -> !fir.boxproc<() -> ()>
278+
! CHECK: %[[VAL_7:.*]] = fir.convert %[[VAL_6]] : (!fir.boxproc<() -> ()>) -> !fir.boxproc<(!fir.ref<f32>) -> f32>
279+
! CHECK: fir.store %[[VAL_7]] to %[[VAL_4]]#0 : !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
280+
! CHECK: %[[VAL_8:.*]] = fir.load %[[VAL_4]]#1 : !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
281+
! CHECK: return %[[VAL_8]] : !fir.boxproc<(!fir.ref<f32>) -> f32>
282+
end
283+
end
284+
285+
subroutine sub11()
286+
use m
287+
interface
288+
function reffunc(arg) result(pp)
289+
import
290+
integer :: arg
291+
procedure(char_func), pointer :: pp
292+
end
293+
end interface
294+
295+
procedure(char_func), pointer :: p1
296+
! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>> {bindc_name = "p1", uniq_name = "_QFsub11Ep1"}
297+
! CHECK: %[[VAL_1:.*]] = fir.zero_bits (!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>
298+
! CHECK: %[[VAL_2:.*]] = fir.emboxproc %[[VAL_1]] : ((!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>) -> !fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>
299+
! CHECK: fir.store %[[VAL_2]] to %[[VAL_0]] : !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>
300+
! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFsub11Ep1"} : (!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,?>>>>>)
301+
302+
p1 => reffunc(5)
303+
! CHECK: %c5_i32 = arith.constant 5 : i32
304+
! CHECK: %[[VAL_4:.*]]:3 = hlfir.associate %c5_i32 {adapt.valuebyref} : (i32) -> (!fir.ref<i32>, !fir.ref<i32>, i1)
305+
! CHECK: %[[VAL_5:.*]] = fir.call @_QPreffunc(%4#1) fastmath<contract> : (!fir.ref<i32>) -> !fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>
306+
! CHECK: fir.store %[[VAL_5]] to %[[VAL_3]]#0 : !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>
307+
! CHECK: return
308+
end
247309

248310
! CHECK-LABEL: fir.global internal @_QFsub1Ep2 : !fir.boxproc<(!fir.ref<f32>) -> f32> {
249311
! CHECK: %[[VAL_0:.*]] = fir.zero_bits (!fir.ref<f32>) -> f32

‎flang/test/Lower/Intrinsics/associated-proc-pointers.f90

Lines changed: 28 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -114,3 +114,31 @@ character(10) function char_func()
114114
! CHECK: %[[VAL_18:.*]] = arith.cmpi ne, %[[VAL_17]], %[[VAL_14]] : i64
115115
! CHECK: %[[VAL_19:.*]] = arith.andi %[[VAL_16]], %[[VAL_18]] : i1
116116
! CHECK: %[[VAL_20:.*]] = fir.convert %[[VAL_19]] : (i1) -> !fir.logical<4>
117+
118+
subroutine test_proc_pointer_6()
119+
interface
120+
real function func()
121+
end
122+
end interface
123+
logical :: ll
124+
ll = associated(reffunc(), func)
125+
contains
126+
function reffunc() result(pp)
127+
procedure(func), pointer :: pp
128+
end
129+
end
130+
! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.logical<4> {bindc_name = "ll", uniq_name = "_QFtest_proc_pointer_6Ell"}
131+
! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "_QFtest_proc_pointer_6Ell"} : (!fir.ref<!fir.logical<4>>) -> (!fir.ref<!fir.logical<4>>, !fir.ref<!fir.logical<4>>)
132+
! CHECK: %[[VAL_2:.*]] = fir.call @_QFtest_proc_pointer_6Preffunc() fastmath<contract> : () -> !fir.boxproc<() -> f32>
133+
! CHECK: %[[VAL_3:.*]] = fir.address_of(@_QPfunc) : () -> f32
134+
! CHECK: %[[VAL_4:.*]] = fir.emboxproc %[[VAL_3]] : (() -> f32) -> !fir.boxproc<() -> ()>
135+
! CHECK: %[[VAL_5:.*]] = fir.box_addr %[[VAL_2]] : (!fir.boxproc<() -> f32>) -> (() -> f32)
136+
! CHECK: %[[VAL_6:.*]] = fir.box_addr %[[VAL_4]] : (!fir.boxproc<() -> ()>) -> (() -> ())
137+
! CHECK: %[[VAL_7:.*]] = fir.convert %[[VAL_5]] : (() -> f32) -> i64
138+
! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_6]] : (() -> ()) -> i64
139+
! CHECK: %[[VAL_9:.*]] = arith.cmpi eq, %[[VAL_7]], %[[VAL_8]] : i64
140+
! CHECK: %c0_i64 = arith.constant 0 : i64
141+
! CHECK: %[[VAL_10:.*]] = arith.cmpi ne, %c0_i64, %[[VAL_7]] : i64
142+
! CHECK: %[[VAL_11:.*]] = arith.andi %[[VAL_9]], %[[VAL_10]] : i1
143+
! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (i1) -> !fir.logical<4>
144+
! CHECK: hlfir.assign %[[VAL_12]] to %[[VAL_1]]#0 : !fir.logical<4>, !fir.ref<!fir.logical<4>>

0 commit comments

Comments
 (0)