[flang-commits] [flang] [flang] lower ASSOCIATED for procedure pointers (PR #76067)
via flang-commits
flang-commits at lists.llvm.org
Wed Dec 20 07:46:27 PST 2023
https://github.com/jeanPerier created https://github.com/llvm/llvm-project/pull/76067
This is a lot less complex than the data case where the shape has to be accounted for, so the implementation is done inline.
One corner case will not be supported correctly for now: the case where POINTER and TARGET points to the same internal procedure may return false because lowering is creating fir.embox_proc each time the address of an internal procedure is taken, so different thunk for the same internal procedure/host link may be created and compare to false. This will be fixed in a later patch that moves creating of internal procedure fir.embox_proc in the host so that the addresses are the same when the host link is the same. This change is required to properly support the required lifetime of internal procedure addresses anyway (should be the always be the lifetime of the host, even when the address is taken in an internal procedure).
>From 1f142c56663ba79e6f12115dcba602b4816a00b8 Mon Sep 17 00:00:00 2001
From: Jean Perier <jperier at nvidia.com>
Date: Wed, 20 Dec 2023 05:58:11 -0800
Subject: [PATCH] [flang] lower ASSOCIATED for procedure pointers
---
.../flang/Optimizer/Builder/HLFIRTools.h | 2 +-
.../include/flang/Optimizer/Dialect/FIRType.h | 6 +
.../flang/Optimizer/HLFIR/HLFIRDialect.h | 6 -
flang/lib/Lower/ConvertCall.cpp | 8 +-
flang/lib/Optimizer/Builder/IntrinsicCall.cpp | 27 ++++
.../Intrinsics/associated-proc-pointers.f90 | 116 ++++++++++++++++++
6 files changed, 153 insertions(+), 12 deletions(-)
create mode 100644 flang/test/Lower/Intrinsics/associated-proc-pointers.f90
diff --git a/flang/include/flang/Optimizer/Builder/HLFIRTools.h b/flang/include/flang/Optimizer/Builder/HLFIRTools.h
index e7561dffb75635..fcf0eded0c7ba4 100644
--- a/flang/include/flang/Optimizer/Builder/HLFIRTools.h
+++ b/flang/include/flang/Optimizer/Builder/HLFIRTools.h
@@ -59,7 +59,7 @@ class Entity : public mlir::Value {
bool isVariable() const { return !isValue(); }
bool isMutableBox() const { return hlfir::isBoxAddressType(getType()); }
bool isProcedurePointer() const {
- return hlfir::isBoxProcAddressType(getType());
+ return fir::isBoxProcAddressType(getType());
}
bool isBoxAddressOrValue() const {
return hlfir::isBoxAddressOrValueType(getType());
diff --git a/flang/include/flang/Optimizer/Dialect/FIRType.h b/flang/include/flang/Optimizer/Dialect/FIRType.h
index a79c67dfe6de86..ecfa9839617dab 100644
--- a/flang/include/flang/Optimizer/Dialect/FIRType.h
+++ b/flang/include/flang/Optimizer/Dialect/FIRType.h
@@ -436,6 +436,12 @@ inline bool isBoxAddressOrValue(mlir::Type t) {
return fir::unwrapRefType(t).isa<fir::BaseBoxType>();
}
+/// Is this a fir.boxproc address type?
+inline bool isBoxProcAddressType(mlir::Type t) {
+ t = fir::dyn_cast_ptrEleTy(t);
+ return t && t.isa<fir::BoxProcType>();
+}
+
/// Return a string representation of `ty`.
///
/// fir.array<10x10xf32> -> prefix_10x10xf32
diff --git a/flang/include/flang/Optimizer/HLFIR/HLFIRDialect.h b/flang/include/flang/Optimizer/HLFIR/HLFIRDialect.h
index e8f28485298277..aa68d0811c4868 100644
--- a/flang/include/flang/Optimizer/HLFIR/HLFIRDialect.h
+++ b/flang/include/flang/Optimizer/HLFIR/HLFIRDialect.h
@@ -67,12 +67,6 @@ inline bool isBoxAddressType(mlir::Type type) {
return type && type.isa<fir::BaseBoxType>();
}
-/// Is this a fir.boxproc address type?
-inline bool isBoxProcAddressType(mlir::Type type) {
- type = fir::dyn_cast_ptrEleTy(type);
- return type && type.isa<fir::BoxProcType>();
-}
-
/// Is this a fir.box or fir.class address or value type?
inline bool isBoxAddressOrValueType(mlir::Type type) {
return fir::unwrapRefType(type).isa<fir::BaseBoxType>();
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index fd726c90c07bd0..57ac9d0652b317 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -887,7 +887,7 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
// Handle the procedure pointer actual arguments.
if (actual.isProcedurePointer()) {
// Procedure pointer actual to procedure pointer dummy.
- if (hlfir::isBoxProcAddressType(dummyType))
+ if (fir::isBoxProcAddressType(dummyType))
return PreparedDummyArgument{actual, /*cleanups=*/{}};
// Procedure pointer actual to procedure dummy.
if (hlfir::isFortranProcedureValue(dummyType)) {
@@ -898,7 +898,7 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
// NULL() actual to procedure pointer dummy
if (Fortran::evaluate::IsNullProcedurePointer(expr) &&
- hlfir::isBoxProcAddressType(dummyType)) {
+ fir::isBoxProcAddressType(dummyType)) {
auto boxTy{Fortran::lower::getUntypedBoxProcType(builder.getContext())};
auto tempBoxProc{builder.createTemporary(loc, boxTy)};
hlfir::Entity nullBoxProc(
@@ -909,7 +909,7 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
if (actual.isProcedure()) {
// Procedure actual to procedure pointer dummy.
- if (hlfir::isBoxProcAddressType(dummyType)) {
+ if (fir::isBoxProcAddressType(dummyType)) {
auto tempBoxProc{builder.createTemporary(loc, actual.getType())};
builder.create<fir::StoreOp>(loc, actual, tempBoxProc);
return PreparedDummyArgument{tempBoxProc, /*cleanups=*/{}};
@@ -1555,8 +1555,6 @@ genIntrinsicRefCore(Fortran::lower::PreparedActualArguments &loweredActuals,
}
hlfir::Entity actual = arg.value()->getActual(loc, builder);
- if (actual.isProcedurePointer())
- TODO(loc, "Procedure pointer as actual argument to intrinsics.");
switch (argRules.lowerAs) {
case fir::LowerIntrinsicArgAs::Value:
operands.emplace_back(
diff --git a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
index ff5dbff04360a0..b6d84fb13c2350 100644
--- a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
+++ b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
@@ -2134,6 +2134,33 @@ fir::ExtendedValue
IntrinsicLibrary::genAssociated(mlir::Type resultType,
llvm::ArrayRef<fir::ExtendedValue> args) {
assert(args.size() == 2);
+ if (fir::isBoxProcAddressType(fir::getBase(args[0]).getType())) {
+ mlir::Value pointerBoxProc =
+ builder.create<fir::LoadOp>(loc, fir::getBase(args[0]));
+ mlir::Value pointerTarget =
+ builder.create<fir::BoxAddrOp>(loc, pointerBoxProc);
+ if (isStaticallyAbsent(args[1]))
+ return builder.genIsNotNullAddr(loc, pointerTarget);
+ mlir::Value target = fir::getBase(args[1]);
+ if (fir::isBoxProcAddressType(target.getType()))
+ target = builder.create<fir::LoadOp>(loc, target);
+ if (target.getType().isa<fir::BoxProcType>())
+ target = builder.create<fir::BoxAddrOp>(loc, target);
+ mlir::Type intPtrTy = builder.getIntPtrType();
+ mlir::Value pointerInt =
+ builder.createConvert(loc, intPtrTy, pointerTarget);
+ mlir::Value targetInt = builder.createConvert(loc, intPtrTy, target);
+ mlir::Value sameTarget = builder.create<mlir::arith::CmpIOp>(
+ loc, mlir::arith::CmpIPredicate::eq, pointerInt, targetInt);
+ mlir::Value zero = builder.createIntegerConstant(loc, intPtrTy, 0);
+ mlir::Value notNull = builder.create<mlir::arith::CmpIOp>(
+ loc, mlir::arith::CmpIPredicate::ne, zero, pointerInt);
+ // The not notNull test covers the following two cases:
+ // - TARGET is a procedure that is OPTIONAL and absent at runtime.
+ // - TARGET is a procedure pointer that is NULL.
+ // In both cases, ASSOCIATED should be false if POINTER is NULL.
+ return builder.create<mlir::arith::AndIOp>(loc, sameTarget, notNull);
+ }
auto *pointer =
args[0].match([&](const fir::MutableBoxValue &x) { return &x; },
[&](const auto &) -> const fir::MutableBoxValue * {
diff --git a/flang/test/Lower/Intrinsics/associated-proc-pointers.f90 b/flang/test/Lower/Intrinsics/associated-proc-pointers.f90
new file mode 100644
index 00000000000000..248b0aff8d286e
--- /dev/null
+++ b/flang/test/Lower/Intrinsics/associated-proc-pointers.f90
@@ -0,0 +1,116 @@
+! Test ASSOCIATED() with procedure pointers.
+! RUN: bbc -emit-hlfir -o - %s | FileCheck %s
+
+subroutine test_proc_pointer_1(p, dummy_proc)
+ procedure(), pointer :: p
+ procedure() :: dummy_proc
+ call takes_log(associated(p, dummy_proc))
+end subroutine
+! CHECK-LABEL: func.func @_QPtest_proc_pointer_1(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.boxproc<() -> ()>>,
+! CHECK-SAME: %[[VAL_1:.*]]: !fir.boxproc<() -> ()>) {
+! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFtest_proc_pointer_1Ep"} : (!fir.ref<!fir.boxproc<() -> ()>>) -> (!fir.ref<!fir.boxproc<() -> ()>>, !fir.ref<!fir.boxproc<() -> ()>>)
+! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_2]]#1 : !fir.ref<!fir.boxproc<() -> ()>>
+! CHECK: %[[VAL_4:.*]] = fir.box_addr %[[VAL_3]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+! CHECK: %[[VAL_5:.*]] = fir.box_addr %[[VAL_1]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_4]] : (() -> ()) -> i64
+! CHECK: %[[VAL_7:.*]] = fir.convert %[[VAL_5]] : (() -> ()) -> i64
+! CHECK: %[[VAL_8:.*]] = arith.cmpi eq, %[[VAL_6]], %[[VAL_7]] : i64
+! CHECK: %[[VAL_9:.*]] = arith.constant 0 : i64
+! CHECK: %[[VAL_10:.*]] = arith.cmpi ne, %[[VAL_9]], %[[VAL_6]] : i64
+! CHECK: %[[VAL_11:.*]] = arith.andi %[[VAL_8]], %[[VAL_10]] : i1
+! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (i1) -> !fir.logical<4>
+
+subroutine test_proc_pointer_2(p, p_target)
+ procedure(), pointer :: p, p_target
+ call takes_log(associated(p, p_target))
+end subroutine
+! CHECK-LABEL: func.func @_QPtest_proc_pointer_2(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.boxproc<() -> ()>>,
+! CHECK-SAME: %[[VAL_1:.*]]: !fir.ref<!fir.boxproc<() -> ()>>) {
+! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFtest_proc_pointer_2Ep"} : (!fir.ref<!fir.boxproc<() -> ()>>) -> (!fir.ref<!fir.boxproc<() -> ()>>, !fir.ref<!fir.boxproc<() -> ()>>)
+! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_1]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFtest_proc_pointer_2Ep_target"} : (!fir.ref<!fir.boxproc<() -> ()>>) -> (!fir.ref<!fir.boxproc<() -> ()>>, !fir.ref<!fir.boxproc<() -> ()>>)
+! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_2]]#1 : !fir.ref<!fir.boxproc<() -> ()>>
+! CHECK: %[[VAL_5:.*]] = fir.box_addr %[[VAL_4]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+! CHECK: %[[VAL_6:.*]] = fir.load %[[VAL_3]]#1 : !fir.ref<!fir.boxproc<() -> ()>>
+! CHECK: %[[VAL_7:.*]] = fir.box_addr %[[VAL_6]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_5]] : (() -> ()) -> i64
+! CHECK: %[[VAL_9:.*]] = fir.convert %[[VAL_7]] : (() -> ()) -> i64
+! CHECK: %[[VAL_10:.*]] = arith.cmpi eq, %[[VAL_8]], %[[VAL_9]] : i64
+! CHECK: %[[VAL_11:.*]] = arith.constant 0 : i64
+! CHECK: %[[VAL_12:.*]] = arith.cmpi ne, %[[VAL_11]], %[[VAL_8]] : i64
+! CHECK: %[[VAL_13:.*]] = arith.andi %[[VAL_10]], %[[VAL_12]] : i1
+! CHECK: %[[VAL_14:.*]] = fir.convert %[[VAL_13]] : (i1) -> !fir.logical<4>
+
+subroutine test_proc_pointer_3(p, dummy_proc)
+ procedure(), pointer :: p
+ procedure(), optional :: dummy_proc
+ call takes_log(associated(p, dummy_proc))
+end subroutine
+! CHECK-LABEL: func.func @_QPtest_proc_pointer_3(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.boxproc<() -> ()>>,
+! CHECK-SAME: %[[VAL_1:.*]]: !fir.boxproc<() -> ()>) {
+! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFtest_proc_pointer_3Ep"} : (!fir.ref<!fir.boxproc<() -> ()>>) -> (!fir.ref<!fir.boxproc<() -> ()>>, !fir.ref<!fir.boxproc<() -> ()>>)
+! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_2]]#1 : !fir.ref<!fir.boxproc<() -> ()>>
+! CHECK: %[[VAL_4:.*]] = fir.box_addr %[[VAL_3]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+! CHECK: %[[VAL_5:.*]] = fir.box_addr %[[VAL_1]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_4]] : (() -> ()) -> i64
+! CHECK: %[[VAL_7:.*]] = fir.convert %[[VAL_5]] : (() -> ()) -> i64
+! CHECK: %[[VAL_8:.*]] = arith.cmpi eq, %[[VAL_6]], %[[VAL_7]] : i64
+! CHECK: %[[VAL_9:.*]] = arith.constant 0 : i64
+! CHECK: %[[VAL_10:.*]] = arith.cmpi ne, %[[VAL_9]], %[[VAL_6]] : i64
+! CHECK: %[[VAL_11:.*]] = arith.andi %[[VAL_8]], %[[VAL_10]] : i1
+! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (i1) -> !fir.logical<4>
+
+subroutine test_proc_pointer_4(p)
+ procedure(), pointer :: p
+ external :: some_external
+ call takes_log(associated(p, some_external))
+end subroutine
+! CHECK-LABEL: func.func @_QPtest_proc_pointer_4(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.boxproc<() -> ()>>) {
+! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFtest_proc_pointer_4Ep"} : (!fir.ref<!fir.boxproc<() -> ()>>) -> (!fir.ref<!fir.boxproc<() -> ()>>, !fir.ref<!fir.boxproc<() -> ()>>)
+! CHECK: %[[VAL_2:.*]] = fir.address_of(@_QPsome_external) : () -> ()
+! CHECK: %[[VAL_3:.*]] = fir.emboxproc %[[VAL_2]] : (() -> ()) -> !fir.boxproc<() -> ()>
+! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_1]]#1 : !fir.ref<!fir.boxproc<() -> ()>>
+! CHECK: %[[VAL_5:.*]] = fir.box_addr %[[VAL_4]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+! CHECK: %[[VAL_6:.*]] = fir.box_addr %[[VAL_3]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+! CHECK: %[[VAL_7:.*]] = fir.convert %[[VAL_5]] : (() -> ()) -> i64
+! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_6]] : (() -> ()) -> i64
+! CHECK: %[[VAL_9:.*]] = arith.cmpi eq, %[[VAL_7]], %[[VAL_8]] : i64
+! CHECK: %[[VAL_10:.*]] = arith.constant 0 : i64
+! CHECK: %[[VAL_11:.*]] = arith.cmpi ne, %[[VAL_10]], %[[VAL_7]] : i64
+! CHECK: %[[VAL_12:.*]] = arith.andi %[[VAL_9]], %[[VAL_11]] : i1
+! CHECK: %[[VAL_13:.*]] = fir.convert %[[VAL_12]] : (i1) -> !fir.logical<4>
+
+subroutine test_proc_pointer_5(p, dummy_proc)
+ interface
+ character(10) function char_func()
+ end function
+ end interface
+ procedure(char_func), pointer :: p
+ procedure(char_func) :: dummy_proc
+ call takes_log(associated(p, dummy_proc))
+end subroutine
+! CHECK-LABEL: func.func @_QPtest_proc_pointer_5(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.boxproc<() -> ()>>,
+! CHECK-SAME: %[[VAL_1:.*]]: tuple<!fir.boxproc<() -> ()>, i64> {fir.char_proc}) {
+! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFtest_proc_pointer_5Ep"} : (!fir.ref<!fir.boxproc<() -> ()>>) -> (!fir.ref<!fir.boxproc<() -> ()>>, !fir.ref<!fir.boxproc<() -> ()>>)
+! CHECK: %[[VAL_3:.*]] = fir.extract_value %[[VAL_1]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
+! CHECK: %[[VAL_4:.*]] = fir.box_addr %[[VAL_3]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+! CHECK: %[[VAL_5:.*]] = arith.constant 10 : i64
+! CHECK: %[[VAL_6:.*]] = fir.emboxproc %[[VAL_4]] : (() -> ()) -> !fir.boxproc<() -> ()>
+! CHECK: %[[VAL_7:.*]] = fir.undefined tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK: %[[VAL_8:.*]] = fir.insert_value %[[VAL_7]], %[[VAL_6]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, !fir.boxproc<() -> ()>) -> tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK: %[[VAL_9:.*]] = fir.insert_value %[[VAL_8]], %[[VAL_5]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>, i64) -> tuple<!fir.boxproc<() -> ()>, i64>
+! CHECK: %[[VAL_10:.*]] = fir.extract_value %[[VAL_9]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
+! CHECK: %[[VAL_11:.*]] = fir.load %[[VAL_2]]#1 : !fir.ref<!fir.boxproc<() -> ()>>
+! CHECK: %[[VAL_12:.*]] = fir.box_addr %[[VAL_11]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+! CHECK: %[[VAL_13:.*]] = fir.box_addr %[[VAL_10]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+! CHECK: %[[VAL_14:.*]] = fir.convert %[[VAL_12]] : (() -> ()) -> i64
+! CHECK: %[[VAL_15:.*]] = fir.convert %[[VAL_13]] : (() -> ()) -> i64
+! CHECK: %[[VAL_16:.*]] = arith.cmpi eq, %[[VAL_14]], %[[VAL_15]] : i64
+! CHECK: %[[VAL_17:.*]] = arith.constant 0 : i64
+! CHECK: %[[VAL_18:.*]] = arith.cmpi ne, %[[VAL_17]], %[[VAL_14]] : i64
+! CHECK: %[[VAL_19:.*]] = arith.andi %[[VAL_16]], %[[VAL_18]] : i1
+! CHECK: %[[VAL_20:.*]] = fir.convert %[[VAL_19]] : (i1) -> !fir.logical<4>
More information about the flang-commits
mailing list