[flang-commits] [flang] f3fa603 - [flang] lower ASSOCIATED for procedure pointers (#76067)
via flang-commits
flang-commits at lists.llvm.org
Fri Dec 22 01:59:05 PST 2023
Author: jeanPerier
Date: 2023-12-22T10:59:01+01:00
New Revision: f3fa603d7404ebca7091534bfa18fed25b099204
URL: https://github.com/llvm/llvm-project/commit/f3fa603d7404ebca7091534bfa18fed25b099204
DIFF: https://github.com/llvm/llvm-project/commit/f3fa603d7404ebca7091534bfa18fed25b099204.diff
LOG: [flang] lower ASSOCIATED for procedure pointers (#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).
Added:
flang/test/Lower/Intrinsics/associated-proc-pointers.f90
Modified:
flang/include/flang/Optimizer/Builder/HLFIRTools.h
flang/include/flang/Optimizer/Dialect/FIRType.h
flang/include/flang/Optimizer/HLFIR/HLFIRDialect.h
flang/lib/Lower/ConvertCall.cpp
flang/lib/Optimizer/Builder/IntrinsicCall.cpp
Removed:
################################################################################
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