[flang-commits] [flang] f5dbee0 - [flang][hlfir] Support rank mismatch with IGNORE_TKR(R).
Slava Zakharin via flang-commits
flang-commits at lists.llvm.org
Mon May 22 10:40:40 PDT 2023
Author: Slava Zakharin
Date: 2023-05-22T10:40:29-07:00
New Revision: f5dbee005c06d91b57c414981339a6937de44539
URL: https://github.com/llvm/llvm-project/commit/f5dbee005c06d91b57c414981339a6937de44539
DIFF: https://github.com/llvm/llvm-project/commit/f5dbee005c06d91b57c414981339a6937de44539.diff
LOG: [flang][hlfir] Support rank mismatch with IGNORE_TKR(R).
Reboxing of the actual argument according to the type of the dummy
argument has to be aware of the potential rank mismatch, when
IGNORE_TKR(R) is used. This change only adds support for the mismatching
rank when the dummy argument has unlimited polymorphic type.
Reviewed By: jeanPerier
Differential Revision: https://reviews.llvm.org/D151016
Added:
flang/test/Lower/HLFIR/ignore-rank-unlimited-polymorphic.f90
Modified:
flang/include/flang/Lower/CallInterface.h
flang/include/flang/Optimizer/Dialect/FIRType.h
flang/lib/Lower/CallInterface.cpp
flang/lib/Lower/ConvertCall.cpp
flang/lib/Optimizer/Dialect/FIROps.cpp
flang/lib/Optimizer/Dialect/FIRType.cpp
Removed:
################################################################################
diff --git a/flang/include/flang/Lower/CallInterface.h b/flang/include/flang/Lower/CallInterface.h
index 110403768b493..fc338dbe1e8a9 100644
--- a/flang/include/flang/Lower/CallInterface.h
+++ b/flang/include/flang/Lower/CallInterface.h
@@ -159,6 +159,8 @@ class CallInterface {
bool mayBeModifiedByCall() const;
/// Can the argument be read by the callee?
bool mayBeReadByCall() const;
+ /// Does the argument have the specified IgnoreTKR flag?
+ bool testTKR(Fortran::common::IgnoreTKR flag) const;
/// Is the argument INTENT(OUT)
bool isIntentOut() const;
/// Does the argument have the CONTIGUOUS attribute or have explicit shape?
diff --git a/flang/include/flang/Optimizer/Dialect/FIRType.h b/flang/include/flang/Optimizer/Dialect/FIRType.h
index ad3fb18568607..5749cdcab46bd 100644
--- a/flang/include/flang/Optimizer/Dialect/FIRType.h
+++ b/flang/include/flang/Optimizer/Dialect/FIRType.h
@@ -330,6 +330,9 @@ inline bool boxHasAddendum(fir::BaseBoxType boxTy) {
fir::isUnlimitedPolymorphicType(boxTy);
}
+/// Get the rank from a !fir.box type.
+unsigned getBoxRank(mlir::Type boxTy);
+
/// Return the inner type of the given type.
mlir::Type unwrapInnerType(mlir::Type ty);
diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp
index 2342dc41da651..b7c4d920b37c5 100644
--- a/flang/lib/Lower/CallInterface.cpp
+++ b/flang/lib/Lower/CallInterface.cpp
@@ -1175,6 +1175,20 @@ bool Fortran::lower::CallInterface<T>::PassedEntity::mayBeReadByCall() const {
return true;
return characteristics->GetIntent() != Fortran::common::Intent::Out;
}
+
+template <typename T>
+bool Fortran::lower::CallInterface<T>::PassedEntity::testTKR(
+ Fortran::common::IgnoreTKR flag) const {
+ if (!characteristics)
+ return false;
+ const auto *dummy =
+ std::get_if<Fortran::evaluate::characteristics::DummyDataObject>(
+ &characteristics->u);
+ if (!dummy)
+ return false;
+ return dummy->ignoreTKR.test(flag);
+}
+
template <typename T>
bool Fortran::lower::CallInterface<T>::PassedEntity::isIntentOut() const {
if (!characteristics)
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index ad7e177020522..0c9d7af9678ec 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -956,8 +956,8 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
entity = hlfir::genVariableBox(loc, builder, entity);
// Ensures the box has the right attributes and that it holds an
// addendum if needed.
- mlir::Type boxEleType =
- entity.getType().cast<fir::BaseBoxType>().getEleTy();
+ fir::BaseBoxType actualBoxType = entity.getType().cast<fir::BaseBoxType>();
+ mlir::Type boxEleType = actualBoxType.getEleTy();
// For now, assume it is not OK to pass the allocatable/pointer
// descriptor to a non pointer/allocatable dummy. That is a strict
// interpretation of 18.3.6 point 4 that stipulates the descriptor
@@ -968,14 +968,30 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
// polymorphic might unconditionally read the addendum. Intrinsic type
// descriptors may not have an addendum, the rebox below will create a
// descriptor with an addendum in such case.
- const bool actualBoxHasAddendum =
- fir::unwrapRefType(boxEleType).isa<fir::RecordType, mlir::NoneType>();
+ const bool actualBoxHasAddendum = fir::boxHasAddendum(actualBoxType);
const bool needToAddAddendum =
fir::isUnlimitedPolymorphicType(dummyType) && !actualBoxHasAddendum;
- if (needToAddAddendum || actualBoxHasAllocatableOrPointerFlag)
+ mlir::Type reboxType = dummyType;
+ if (needToAddAddendum || actualBoxHasAllocatableOrPointerFlag) {
+ if (fir::getBoxRank(dummyType) != fir::getBoxRank(actualBoxType)) {
+ // This may happen only with IGNORE_TKR(R).
+ if (!arg.testTKR(Fortran::common::IgnoreTKR::Rank))
+ DIE("actual and dummy arguments must have equal ranks");
+ // Only allow it for unlimited polymorphic dummy arguments
+ // for now.
+ if (!fir::isUnlimitedPolymorphicType(dummyType))
+ TODO(loc, "actual/dummy rank mismatch for not unlimited polymorphic "
+ "dummy.");
+ auto elementType = fir::updateTypeForUnlimitedPolymorphic(boxEleType);
+ if (fir::isAssumedType(dummyType))
+ reboxType = fir::BoxType::get(elementType);
+ else
+ reboxType = fir::ClassType::get(elementType);
+ }
entity = hlfir::Entity{builder.create<fir::ReboxOp>(
- loc, dummyType, entity, /*shape=*/mlir::Value{},
+ loc, reboxType, entity, /*shape=*/mlir::Value{},
/*slice=*/mlir::Value{})};
+ }
addr = entity;
} else {
addr = hlfir::genVariableRawAddress(loc, builder, entity);
diff --git a/flang/lib/Optimizer/Dialect/FIROps.cpp b/flang/lib/Optimizer/Dialect/FIROps.cpp
index 3f40b75d9485f..cad27cf703bc1 100644
--- a/flang/lib/Optimizer/Dialect/FIROps.cpp
+++ b/flang/lib/Optimizer/Dialect/FIROps.cpp
@@ -2249,14 +2249,6 @@ static mlir::Type getBoxScalarEleTy(mlir::Type boxTy) {
return eleTy;
}
-/// Get the rank from a !fir.box type
-static unsigned getBoxRank(mlir::Type boxTy) {
- auto eleTy = fir::dyn_cast_ptrOrBoxEleTy(boxTy);
- if (auto seqTy = eleTy.dyn_cast<fir::SequenceType>())
- return seqTy.getDimension();
- return 0;
-}
-
/// Test if \p t1 and \p t2 are compatible character types (if they can
/// represent the same type at runtime).
static bool areCompatibleCharacterTypes(mlir::Type t1, mlir::Type t2) {
@@ -2276,9 +2268,9 @@ mlir::LogicalResult fir::ReboxOp::verify() {
auto outBoxTy = getType();
if (fir::isa_unknown_size_box(outBoxTy))
return emitOpError("result type must not have unknown rank or type");
- auto inputRank = getBoxRank(inputBoxTy);
+ auto inputRank = fir::getBoxRank(inputBoxTy);
auto inputEleTy = getBoxScalarEleTy(inputBoxTy);
- auto outRank = getBoxRank(outBoxTy);
+ auto outRank = fir::getBoxRank(outBoxTy);
auto outEleTy = getBoxScalarEleTy(outBoxTy);
if (auto sliceVal = getSlice()) {
diff --git a/flang/lib/Optimizer/Dialect/FIRType.cpp b/flang/lib/Optimizer/Dialect/FIRType.cpp
index 957d086597548..50268287bee61 100644
--- a/flang/lib/Optimizer/Dialect/FIRType.cpp
+++ b/flang/lib/Optimizer/Dialect/FIRType.cpp
@@ -382,6 +382,13 @@ mlir::Type unwrapSeqOrBoxedSeqType(mlir::Type ty) {
return ty;
}
+unsigned getBoxRank(mlir::Type boxTy) {
+ auto eleTy = fir::dyn_cast_ptrOrBoxEleTy(boxTy);
+ if (auto seqTy = eleTy.dyn_cast<fir::SequenceType>())
+ return seqTy.getDimension();
+ return 0;
+}
+
/// Return the ISO_C_BINDING intrinsic module value of type \p ty.
int getTypeCode(mlir::Type ty, const fir::KindMapping &kindMap) {
unsigned width = 0;
diff --git a/flang/test/Lower/HLFIR/ignore-rank-unlimited-polymorphic.f90 b/flang/test/Lower/HLFIR/ignore-rank-unlimited-polymorphic.f90
new file mode 100644
index 0000000000000..4209cfdf66e39
--- /dev/null
+++ b/flang/test/Lower/HLFIR/ignore-rank-unlimited-polymorphic.f90
@@ -0,0 +1,138 @@
+! Test passing mismatching rank arguments to unlimited polymorphic
+! dummy with IGNORE_TKR(R).
+! RUN: bbc -hlfir -emit-fir -polymorphic-type -o - -I nowhere %s 2>&1 | FileCheck %s
+
+module m
+ interface
+ subroutine callee(x)
+ class(*) :: x
+ !dir$ ignore_tkr (r) x
+ end subroutine callee
+ end interface
+end module m
+
+subroutine test_integer_scalar
+ use m
+ integer :: x
+ call callee(x)
+end subroutine test_integer_scalar
+! CHECK-LABEL: func.func @_QPtest_integer_scalar() {
+! CHECK: %[[VAL_0:.*]] = fir.alloca i32 {bindc_name = "x", uniq_name = "_QFtest_integer_scalarEx"}
+! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "_QFtest_integer_scalarEx"} : (!fir.ref<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
+! CHECK: %[[VAL_2:.*]] = fir.embox %[[VAL_1]]#0 : (!fir.ref<i32>) -> !fir.box<i32>
+! CHECK: %[[VAL_3:.*]] = fir.rebox %[[VAL_2]] : (!fir.box<i32>) -> !fir.class<none>
+! CHECK: fir.call @_QPcallee(%[[VAL_3]]) fastmath<contract> : (!fir.class<none>) -> ()
+! CHECK: return
+! CHECK: }
+
+subroutine test_real_explicit_shape_array
+ use m
+ real :: x(10)
+ call callee(x)
+end subroutine test_real_explicit_shape_array
+! CHECK-LABEL: func.func @_QPtest_real_explicit_shape_array() {
+! CHECK: %[[VAL_0:.*]] = arith.constant 10 : index
+! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.array<10xf32> {bindc_name = "x", uniq_name = "_QFtest_real_explicit_shape_arrayEx"}
+! CHECK: %[[VAL_2:.*]] = fir.shape %[[VAL_0]] : (index) -> !fir.shape<1>
+! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_1]](%[[VAL_2]]) {uniq_name = "_QFtest_real_explicit_shape_arrayEx"} : (!fir.ref<!fir.array<10xf32>>, !fir.shape<1>) -> (!fir.ref<!fir.array<10xf32>>, !fir.ref<!fir.array<10xf32>>)
+! CHECK: %[[VAL_4:.*]] = fir.embox %[[VAL_3]]#0(%[[VAL_2]]) : (!fir.ref<!fir.array<10xf32>>, !fir.shape<1>) -> !fir.box<!fir.array<10xf32>>
+! CHECK: %[[VAL_5:.*]] = fir.rebox %[[VAL_4]] : (!fir.box<!fir.array<10xf32>>) -> !fir.class<!fir.array<10xnone>>
+! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (!fir.class<!fir.array<10xnone>>) -> !fir.class<none>
+! CHECK: fir.call @_QPcallee(%[[VAL_6]]) fastmath<contract> : (!fir.class<none>) -> ()
+! CHECK: return
+! CHECK: }
+
+subroutine test_logical_assumed_shape_array(x)
+ use m
+ logical :: x(:)
+ call callee(x)
+end subroutine test_logical_assumed_shape_array
+! CHECK-LABEL: func.func @_QPtest_logical_assumed_shape_array(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.box<!fir.array<?x!fir.logical<4>>> {fir.bindc_name = "x"}) {
+! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "_QFtest_logical_assumed_shape_arrayEx"} : (!fir.box<!fir.array<?x!fir.logical<4>>>) -> (!fir.box<!fir.array<?x!fir.logical<4>>>, !fir.box<!fir.array<?x!fir.logical<4>>>)
+! CHECK: %[[VAL_2:.*]] = fir.rebox %[[VAL_1]]#0 : (!fir.box<!fir.array<?x!fir.logical<4>>>) -> !fir.class<!fir.array<?xnone>>
+! CHECK: %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (!fir.class<!fir.array<?xnone>>) -> !fir.class<none>
+! CHECK: fir.call @_QPcallee(%[[VAL_3]]) fastmath<contract> : (!fir.class<none>) -> ()
+! CHECK: return
+! CHECK: }
+
+subroutine test_real_2d_pointer(x)
+ use m
+ real, pointer :: x(:, :)
+ call callee(x)
+end subroutine test_real_2d_pointer
+! CHECK-LABEL: func.func @_QPtest_real_2d_pointer(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>> {fir.bindc_name = "x"}) {
+! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFtest_real_2d_pointerEx"} : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>) -> (!fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>, !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>)
+! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x?xf32>>>>
+! CHECK: %[[VAL_3:.*]] = fir.rebox %[[VAL_2]] : (!fir.box<!fir.ptr<!fir.array<?x?xf32>>>) -> !fir.class<!fir.ptr<!fir.array<?x?xnone>>>
+! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.class<!fir.ptr<!fir.array<?x?xnone>>>) -> !fir.class<none>
+! CHECK: fir.call @_QPcallee(%[[VAL_4]]) fastmath<contract> : (!fir.class<none>) -> ()
+! CHECK: return
+! CHECK: }
+
+subroutine test_up_assumed_shape_1d_array(x)
+ use m
+ class(*) :: x(:)
+ call callee(x)
+end subroutine test_up_assumed_shape_1d_array
+! CHECK-LABEL: func.func @_QPtest_up_assumed_shape_1d_array(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.class<!fir.array<?xnone>> {fir.bindc_name = "x"}) {
+! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "_QFtest_up_assumed_shape_1d_arrayEx"} : (!fir.class<!fir.array<?xnone>>) -> (!fir.class<!fir.array<?xnone>>, !fir.class<!fir.array<?xnone>>)
+! CHECK: %[[VAL_2:.*]] = fir.convert %[[VAL_1]]#0 : (!fir.class<!fir.array<?xnone>>) -> !fir.class<none>
+! CHECK: fir.call @_QPcallee(%[[VAL_2]]) fastmath<contract> : (!fir.class<none>) -> ()
+! CHECK: return
+! CHECK: }
+
+subroutine test_derived_explicit_shape_array
+ use m
+ type t1
+ real, allocatable :: a
+ end type t1
+ type(t1) :: x(10)
+ call callee(x)
+end subroutine test_derived_explicit_shape_array
+! CHECK-LABEL: func.func @_QPtest_derived_explicit_shape_array() {
+! CHECK: %[[VAL_0:.*]] = arith.constant 10 : index
+! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.array<10x!fir.type<_QFtest_derived_explicit_shape_arrayTt1{a:!fir.box<!fir.heap<f32>>}>> {bindc_name = "x", uniq_name = "_QFtest_derived_explicit_shape_arrayEx"}
+! CHECK: %[[VAL_2:.*]] = fir.shape %[[VAL_0]] : (index) -> !fir.shape<1>
+! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_1]](%[[VAL_2]]) {uniq_name = "_QFtest_derived_explicit_shape_arrayEx"} : (!fir.ref<!fir.array<10x!fir.type<_QFtest_derived_explicit_shape_arrayTt1{a:!fir.box<!fir.heap<f32>>}>>>, !fir.shape<1>) -> (!fir.ref<!fir.array<10x!fir.type<_QFtest_derived_explicit_shape_arrayTt1{a:!fir.box<!fir.heap<f32>>}>>>, !fir.ref<!fir.array<10x!fir.type<_QFtest_derived_explicit_shape_arrayTt1{a:!fir.box<!fir.heap<f32>>}>>>)
+! CHECK: %[[VAL_4:.*]] = fir.shape %[[VAL_0]] : (index) -> !fir.shape<1>
+! CHECK: %[[VAL_5:.*]] = fir.embox %[[VAL_3]]#1(%[[VAL_4]]) : (!fir.ref<!fir.array<10x!fir.type<_QFtest_derived_explicit_shape_arrayTt1{a:!fir.box<!fir.heap<f32>>}>>>, !fir.shape<1>) -> !fir.box<!fir.array<10x!fir.type<_QFtest_derived_explicit_shape_arrayTt1{a:!fir.box<!fir.heap<f32>>}>>>
+! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_5]] : (!fir.box<!fir.array<10x!fir.type<_QFtest_derived_explicit_shape_arrayTt1{a:!fir.box<!fir.heap<f32>>}>>>) -> !fir.box<none>
+! CHECK: %[[VAL_10:.*]] = fir.call @_FortranAInitialize(%[[VAL_8]], %{{.*}}, %{{.*}}) fastmath<contract> : (!fir.box<none>, !fir.ref<i8>, i32) -> none
+! CHECK: %[[VAL_11:.*]] = fir.embox %[[VAL_3]]#0(%[[VAL_2]]) : (!fir.ref<!fir.array<10x!fir.type<_QFtest_derived_explicit_shape_arrayTt1{a:!fir.box<!fir.heap<f32>>}>>>, !fir.shape<1>) -> !fir.box<!fir.array<10x!fir.type<_QFtest_derived_explicit_shape_arrayTt1{a:!fir.box<!fir.heap<f32>>}>>>
+! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (!fir.box<!fir.array<10x!fir.type<_QFtest_derived_explicit_shape_arrayTt1{a:!fir.box<!fir.heap<f32>>}>>>) -> !fir.class<none>
+! CHECK: fir.call @_QPcallee(%[[VAL_12]]) fastmath<contract> : (!fir.class<none>) -> ()
+! CHECK: return
+! CHECK: }
+
+subroutine test_up_allocatable_2d_array(x)
+ use m
+ class(*), allocatable :: x(:, :)
+ call callee(x)
+end subroutine test_up_allocatable_2d_array
+! CHECK-LABEL: func.func @_QPtest_up_allocatable_2d_array(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.class<!fir.heap<!fir.array<?x?xnone>>>> {fir.bindc_name = "x"}) {
+! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<allocatable>, uniq_name = "_QFtest_up_allocatable_2d_arrayEx"} : (!fir.ref<!fir.class<!fir.heap<!fir.array<?x?xnone>>>>) -> (!fir.ref<!fir.class<!fir.heap<!fir.array<?x?xnone>>>>, !fir.ref<!fir.class<!fir.heap<!fir.array<?x?xnone>>>>)
+! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref<!fir.class<!fir.heap<!fir.array<?x?xnone>>>>
+! CHECK: %[[VAL_3:.*]] = fir.rebox %[[VAL_2]] : (!fir.class<!fir.heap<!fir.array<?x?xnone>>>) -> !fir.class<!fir.heap<!fir.array<?x?xnone>>>
+! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.class<!fir.heap<!fir.array<?x?xnone>>>) -> !fir.class<none>
+! CHECK: fir.call @_QPcallee(%[[VAL_4]]) fastmath<contract> : (!fir.class<none>) -> ()
+! CHECK: return
+! CHECK: }
+
+subroutine test_up_pointer_1d_array(x)
+ use m
+ class(*), pointer :: x(:)
+ call callee(x)
+end subroutine test_up_pointer_1d_array
+! CHECK-LABEL: func.func @_QPtest_up_pointer_1d_array(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.class<!fir.ptr<!fir.array<?xnone>>>> {fir.bindc_name = "x"}) {
+! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFtest_up_pointer_1d_arrayEx"} : (!fir.ref<!fir.class<!fir.ptr<!fir.array<?xnone>>>>) -> (!fir.ref<!fir.class<!fir.ptr<!fir.array<?xnone>>>>, !fir.ref<!fir.class<!fir.ptr<!fir.array<?xnone>>>>)
+! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_1]]#0 : !fir.ref<!fir.class<!fir.ptr<!fir.array<?xnone>>>>
+! CHECK: %[[VAL_3:.*]] = fir.rebox %[[VAL_2]] : (!fir.class<!fir.ptr<!fir.array<?xnone>>>) -> !fir.class<!fir.ptr<!fir.array<?xnone>>>
+! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.class<!fir.ptr<!fir.array<?xnone>>>) -> !fir.class<none>
+! CHECK: fir.call @_QPcallee(%[[VAL_4]]) fastmath<contract> : (!fir.class<none>) -> ()
+! CHECK: return
+! CHECK: }
More information about the flang-commits
mailing list