Skip to content

Commit 453a0e4

Browse files
jeanPerierjeanPerier
authored
[flang] handle assume-rank descriptor updates in calls (#95229)
Deal with the cases where lower bounds, or attribute, or dynamic type must be updated when passing an assumed-rank actual argument to an assumed-rank dummy argument. copy-in/copy-out and passing target assumed-rank to intent(in) pointers will be handled in separate patch.
1 parent b37f9e0 commit 453a0e4

File tree

2 files changed

+85
-23
lines changed

2 files changed

+85
-23
lines changed

‎flang/lib/Lower/ConvertCall.cpp

Lines changed: 22 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -1085,11 +1085,8 @@ static hlfir::Entity fixProcedureDummyMismatch(mlir::Location loc,
10851085
mlir::Value static getZeroLowerBounds(mlir::Location loc,
10861086
fir::FirOpBuilder &builder,
10871087
hlfir::Entity entity) {
1088-
// Assumed rank should not fall here, but better safe than sorry until
1089-
// implemented.
1090-
if (entity.isAssumedRank())
1091-
TODO(loc, "setting lower bounds of assumed rank to zero before passing it "
1092-
"to BIND(C) procedure");
1088+
assert(!entity.isAssumedRank() &&
1089+
"assumed-rank must use fir.rebox_assumed_rank");
10931090
if (entity.getRank() < 1)
10941091
return {};
10951092
mlir::Value zero =
@@ -1216,14 +1213,16 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
12161213
if (mustSetDynamicTypeToDummyType) {
12171214
// Note: this is important to do this before any copy-in or copy so
12181215
// that the dummy is contiguous according to the dummy type.
1219-
if (actualIsAssumedRank)
1220-
TODO(loc, "passing polymorphic assumed-rank to non polymorphic dummy "
1221-
"argument");
12221216
mlir::Type boxType = fir::BoxType::get(
12231217
hlfir::getFortranElementOrSequenceType(dummyTypeWithActualRank));
1224-
entity = hlfir::Entity{builder.create<fir::ReboxOp>(
1225-
loc, boxType, entity, /*shape=*/mlir::Value{},
1226-
/*slice=*/mlir::Value{})};
1218+
if (actualIsAssumedRank) {
1219+
entity = hlfir::Entity{builder.create<fir::ReboxAssumedRankOp>(
1220+
loc, boxType, entity, fir::LowerBoundModifierAttribute::SetToOnes)};
1221+
} else {
1222+
entity = hlfir::Entity{builder.create<fir::ReboxOp>(
1223+
loc, boxType, entity, /*shape=*/mlir::Value{},
1224+
/*slice=*/mlir::Value{})};
1225+
}
12271226
}
12281227
if (arg.hasValueAttribute() ||
12291228
// Constant expressions might be lowered as variables with
@@ -1330,19 +1329,19 @@ static PreparedDummyArgument preparePresentUserCallActualArgument(
13301329
if (needToAddAddendum || actualBoxHasAllocatableOrPointerFlag ||
13311330
needsZeroLowerBounds) {
13321331
if (actualIsAssumedRank) {
1333-
if (needToAddAddendum)
1334-
TODO(loc, "passing intrinsic assumed-rank to unlimited polymorphic "
1335-
"assumed-rank");
1336-
else
1337-
TODO(loc, "passing pointer or allocatable assumed-rank to non "
1338-
"pointer non allocatable assumed-rank");
1332+
auto lbModifier = needsZeroLowerBounds
1333+
? fir::LowerBoundModifierAttribute::SetToZeroes
1334+
: fir::LowerBoundModifierAttribute::SetToOnes;
1335+
entity = hlfir::Entity{builder.create<fir::ReboxAssumedRankOp>(
1336+
loc, dummyTypeWithActualRank, entity, lbModifier)};
1337+
} else {
1338+
mlir::Value shift{};
1339+
if (needsZeroLowerBounds)
1340+
shift = getZeroLowerBounds(loc, builder, entity);
1341+
entity = hlfir::Entity{builder.create<fir::ReboxOp>(
1342+
loc, dummyTypeWithActualRank, entity, /*shape=*/shift,
1343+
/*slice=*/mlir::Value{})};
13391344
}
1340-
mlir::Value shift{};
1341-
if (needsZeroLowerBounds)
1342-
shift = getZeroLowerBounds(loc, builder, entity);
1343-
entity = hlfir::Entity{builder.create<fir::ReboxOp>(
1344-
loc, dummyTypeWithActualRank, entity, /*shape=*/shift,
1345-
/*slice=*/mlir::Value{})};
13461345
}
13471346
addr = entity;
13481347
} else {

‎flang/test/Lower/HLFIR/assumed-rank-calls.f90

Lines changed: 63 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,63 @@
1+
! Test passing of assumed-ranks that require creating a
2+
! a new descriptor for the dummy argument (different lower bounds,
3+
! attribute, or dynamic type)
4+
! RUN: bbc -emit-hlfir -allow-assumed-rank -o - %s | FileCheck %s
5+
6+
subroutine test_alloc_to_nonalloc(x)
7+
real, allocatable :: x(..)
8+
interface
9+
subroutine takes_assumed_rank(x)
10+
real :: x(..)
11+
end subroutine
12+
end interface
13+
call takes_assumed_rank(x)
14+
end subroutine
15+
! CHECK-LABEL: func.func @_QPtest_alloc_to_nonalloc(
16+
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<*:f32>>>> {fir.bindc_name = "x"}) {
17+
! CHECK: %[[VAL_1:.*]] = fir.dummy_scope : !fir.dscope
18+
! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0]] dummy_scope %[[VAL_1]] {fortran_attrs = #fir.var_attrs<allocatable>, uniq_name = "_QFtest_alloc_to_nonallocEx"} : (!fir.ref<!fir.box<!fir.heap<!fir.array<*:f32>>>>, !fir.dscope) -> (!fir.ref<!fir.box<!fir.heap<!fir.array<*:f32>>>>, !fir.ref<!fir.box<!fir.heap<!fir.array<*:f32>>>>)
19+
! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_2]]#0 : !fir.ref<!fir.box<!fir.heap<!fir.array<*:f32>>>>
20+
! CHECK: %[[VAL_4:.*]] = fir.rebox_assumed_rank %[[VAL_3]] lbs ones : (!fir.box<!fir.heap<!fir.array<*:f32>>>) -> !fir.box<!fir.array<*:f32>>
21+
! CHECK: fir.call @_QPtakes_assumed_rank(%[[VAL_4]]) fastmath<contract> : (!fir.box<!fir.array<*:f32>>) -> ()
22+
! CHECK: return
23+
! CHECK: }
24+
25+
subroutine test_to_bindc(x)
26+
real :: x(..)
27+
interface
28+
subroutine bindc_func(x) bind(c)
29+
real :: x(..)
30+
end subroutine
31+
end interface
32+
call bindc_func(x)
33+
end subroutine
34+
! CHECK-LABEL: func.func @_QPtest_to_bindc(
35+
! CHECK-SAME: %[[VAL_0:.*]]: !fir.box<!fir.array<*:f32>> {fir.bindc_name = "x"}) {
36+
! CHECK: %[[VAL_1:.*]] = fir.dummy_scope : !fir.dscope
37+
! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0]] dummy_scope %[[VAL_1]] {uniq_name = "_QFtest_to_bindcEx"} : (!fir.box<!fir.array<*:f32>>, !fir.dscope) -> (!fir.box<!fir.array<*:f32>>, !fir.box<!fir.array<*:f32>>)
38+
! CHECK: %[[VAL_3:.*]] = fir.rebox_assumed_rank %[[VAL_2]]#0 lbs zeroes : (!fir.box<!fir.array<*:f32>>) -> !fir.box<!fir.array<*:f32>>
39+
! CHECK: fir.call @bindc_func(%[[VAL_3]]) fastmath<contract> {is_bind_c} : (!fir.box<!fir.array<*:f32>>) -> ()
40+
! CHECK: return
41+
! CHECK: }
42+
43+
subroutine test_poly_to_nonepoly(x)
44+
type t
45+
integer :: i
46+
end type
47+
class(t) :: x(..)
48+
interface
49+
subroutine takes_assumed_rank_t(x)
50+
import :: t
51+
type(t) :: x(..)
52+
end subroutine
53+
end interface
54+
call takes_assumed_rank_t(x)
55+
end subroutine
56+
! CHECK-LABEL: func.func @_QPtest_poly_to_nonepoly(
57+
! CHECK-SAME: %[[VAL_0:.*]]: !fir.class<!fir.array<*:!fir.type<_QFtest_poly_to_nonepolyTt{i:i32}>>> {fir.bindc_name = "x"}) {
58+
! CHECK: %[[VAL_1:.*]] = fir.dummy_scope : !fir.dscope
59+
! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0]] dummy_scope %[[VAL_1]] {uniq_name = "_QFtest_poly_to_nonepolyEx"} : (!fir.class<!fir.array<*:!fir.type<_QFtest_poly_to_nonepolyTt{i:i32}>>>, !fir.dscope) -> (!fir.class<!fir.array<*:!fir.type<_QFtest_poly_to_nonepolyTt{i:i32}>>>, !fir.class<!fir.array<*:!fir.type<_QFtest_poly_to_nonepolyTt{i:i32}>>>)
60+
! CHECK: %[[VAL_3:.*]] = fir.rebox_assumed_rank %[[VAL_2]]#0 lbs ones : (!fir.class<!fir.array<*:!fir.type<_QFtest_poly_to_nonepolyTt{i:i32}>>>) -> !fir.box<!fir.array<*:!fir.type<_QFtest_poly_to_nonepolyTt{i:i32}>>>
61+
! CHECK: fir.call @_QPtakes_assumed_rank_t(%[[VAL_3]]) fastmath<contract> : (!fir.box<!fir.array<*:!fir.type<_QFtest_poly_to_nonepolyTt{i:i32}>>>) -> ()
62+
! CHECK: return
63+
! CHECK: }

0 commit comments

Comments
 (0)