Skip to content

Commit 8370785

Browse files
jeanPerierjeanPerier
committed
[flang] lower assumed-ranks captured in internal procedures
1 parent fa08e97 commit 8370785

File tree

4 files changed

+155
-10
lines changed

4 files changed

+155
-10
lines changed

‎flang/lib/Lower/ConvertType.cpp

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -280,10 +280,11 @@ struct TypeBuilderImpl {
280280
if (ultimate.IsObjectArray()) {
281281
auto shapeExpr =
282282
Fortran::evaluate::GetShape(converter.getFoldingContext(), ultimate);
283-
if (!shapeExpr)
284-
TODO(loc, "assumed rank symbol type");
285283
fir::SequenceType::Shape shape;
286-
translateShape(shape, std::move(*shapeExpr));
284+
// If there is no shapExpr, this is an assumed-rank, and the empty shape
285+
// will build the desired fir.array<*:T> type.
286+
if (shapeExpr)
287+
translateShape(shape, std::move(*shapeExpr));
287288
ty = fir::SequenceType::get(shape, ty);
288289
}
289290
if (Fortran::semantics::IsPointer(symbol))

‎flang/lib/Lower/HostAssociations.cpp

Lines changed: 6 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -366,7 +366,8 @@ class CapturedAllocatableAndPointer
366366
}
367367
};
368368

369-
/// Class defining how arrays are captured inside internal procedures.
369+
/// Class defining how arrays, including assumed-ranks, are captured inside
370+
/// internal procedures.
370371
/// Array are captured via a `fir.box<fir.array<T>>` descriptor that belongs to
371372
/// the host tuple. This allows capturing lower bounds, which can be done by
372373
/// providing a ShapeShiftOp argument to the EmboxOp.
@@ -430,7 +431,7 @@ class CapturedArrays : public CapturedSymbols<CapturedArrays> {
430431
mlir::Value box = args.valueInTuple;
431432
mlir::IndexType idxTy = builder.getIndexType();
432433
llvm::SmallVector<mlir::Value> lbounds;
433-
if (!ba.lboundIsAllOnes()) {
434+
if (!ba.lboundIsAllOnes() && !Fortran::evaluate::IsAssumedRank(sym)) {
434435
if (ba.isStaticArray()) {
435436
for (std::int64_t lb : ba.staticLBound())
436437
lbounds.emplace_back(builder.createIntegerConstant(loc, idxTy, lb));
@@ -488,7 +489,8 @@ class CapturedArrays : public CapturedSymbols<CapturedArrays> {
488489
const Fortran::semantics::DeclTypeSpec *type = sym.GetType();
489490
bool isPolymorphic = type && type->IsPolymorphic();
490491
return isScalarOrContiguous && !isPolymorphic &&
491-
!isDerivedWithLenParameters(sym);
492+
!isDerivedWithLenParameters(sym) &&
493+
!Fortran::evaluate::IsAssumedRank(sym);
492494
}
493495
};
494496
} // namespace
@@ -514,7 +516,7 @@ walkCaptureCategories(T visitor, Fortran::lower::AbstractConverter &converter,
514516
if (Fortran::semantics::IsAllocatableOrPointer(sym) ||
515517
sym.GetUltimate().test(Fortran::semantics::Symbol::Flag::CrayPointee))
516518
return CapturedAllocatableAndPointer::visit(visitor, converter, sym, ba);
517-
if (ba.isArray())
519+
if (ba.isArray()) // include assumed-ranks.
518520
return CapturedArrays::visit(visitor, converter, sym, ba);
519521
if (Fortran::semantics::IsPolymorphic(sym))
520522
return CapturedPolymorphicScalar::visit(visitor, converter, sym, ba);

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

Lines changed: 17 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -329,7 +329,18 @@ class MutablePropertyWriter {
329329
mlir::Value fir::factory::createUnallocatedBox(
330330
fir::FirOpBuilder &builder, mlir::Location loc, mlir::Type boxType,
331331
mlir::ValueRange nonDeferredParams, mlir::Value typeSourceBox) {
332-
auto baseAddrType = mlir::dyn_cast<fir::BaseBoxType>(boxType).getEleTy();
332+
auto baseBoxType = mlir::cast<fir::BaseBoxType>(boxType);
333+
// Giving unallocated/disassociated status to assumed-rank POINTER/
334+
// ALLOCATABLE is not directly possible to a Fortran user. But the
335+
// compiler may need to create such temporary descriptor to deal with
336+
// cases like ENTRY or host association. In such case, all that mater
337+
// is that the base address is set to zero and the rank is set to
338+
// some defined value. Hence, a scalar descriptor is created and
339+
// cast to assumed-rank.
340+
const bool isAssumedRank = baseBoxType.isAssumedRank();
341+
if (isAssumedRank)
342+
baseBoxType = baseBoxType.getBoxTypeWithNewShape(/*rank=*/0);
343+
auto baseAddrType = baseBoxType.getEleTy();
333344
if (!fir::isa_ref_type(baseAddrType))
334345
baseAddrType = builder.getRefType(baseAddrType);
335346
auto type = fir::unwrapRefType(baseAddrType);
@@ -361,8 +372,11 @@ mlir::Value fir::factory::createUnallocatedBox(
361372
}
362373
}
363374
mlir::Value emptySlice;
364-
return builder.create<fir::EmboxOp>(loc, boxType, nullAddr, shape, emptySlice,
365-
lenParams, typeSourceBox);
375+
auto embox = builder.create<fir::EmboxOp>(
376+
loc, baseBoxType, nullAddr, shape, emptySlice, lenParams, typeSourceBox);
377+
if (isAssumedRank)
378+
return builder.createConvert(loc, boxType, embox);
379+
return embox;
366380
}
367381

368382
fir::MutableBoxValue fir::factory::createTempMutableBox(

‎flang/test/Lower/HLFIR/assumed-rank-internal-proc.f90

Lines changed: 128 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,128 @@
1+
! Test assumed-rank capture inside internal procedures.
2+
! RUN: bbc -emit-hlfir -o - %s -allow-assumed-rank | FileCheck %s
3+
4+
subroutine test_assumed_rank(x)
5+
real :: x(..)
6+
interface
7+
subroutine some_sub(x)
8+
real :: x(..)
9+
end subroutine
10+
end interface
11+
call internal()
12+
contains
13+
subroutine internal()
14+
call some_sub(x)
15+
end subroutine
16+
end subroutine
17+
! CHECK-LABEL: func.func @_QPtest_assumed_rank(
18+
! CHECK-SAME: %[[VAL_0:.*]]: !fir.box<!fir.array<*:f32>> {fir.bindc_name = "x"}) {
19+
! CHECK: %[[VAL_1:.*]] = fir.dummy_scope : !fir.dscope
20+
! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0]] dummy_scope %[[VAL_1]] {uniq_name = "_QFtest_assumed_rankEx"} : (!fir.box<!fir.array<*:f32>>, !fir.dscope) -> (!fir.box<!fir.array<*:f32>>, !fir.box<!fir.array<*:f32>>)
21+
! CHECK: %[[VAL_3:.*]] = fir.alloca tuple<!fir.box<!fir.array<*:f32>>>
22+
! CHECK: %[[VAL_4:.*]] = arith.constant 0 : i32
23+
! CHECK: %[[VAL_5:.*]] = fir.coordinate_of %[[VAL_3]], %[[VAL_4]] : (!fir.ref<tuple<!fir.box<!fir.array<*:f32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<*:f32>>>
24+
! CHECK: %[[VAL_6:.*]] = fir.rebox_assumed_rank %[[VAL_2]]#0 lbs preserve : (!fir.box<!fir.array<*:f32>>) -> !fir.box<!fir.array<*:f32>>
25+
! CHECK: fir.store %[[VAL_6]] to %[[VAL_5]] : !fir.ref<!fir.box<!fir.array<*:f32>>>
26+
! CHECK: fir.call @_QFtest_assumed_rankPinternal(%[[VAL_3]]) fastmath<contract> : (!fir.ref<tuple<!fir.box<!fir.array<*:f32>>>>) -> ()
27+
! CHECK: return
28+
! CHECK: }
29+
30+
! CHECK-LABEL: func.func private @_QFtest_assumed_rankPinternal(
31+
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<tuple<!fir.box<!fir.array<*:f32>>>> {fir.host_assoc})
32+
! CHECK: %[[VAL_1:.*]] = fir.dummy_scope : !fir.dscope
33+
! CHECK: %[[VAL_2:.*]] = arith.constant 0 : i32
34+
! CHECK: %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_2]] : (!fir.ref<tuple<!fir.box<!fir.array<*:f32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<*:f32>>>
35+
! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_3]] : !fir.ref<!fir.box<!fir.array<*:f32>>>
36+
! CHECK: %[[VAL_5:.*]]:2 = hlfir.declare %[[VAL_4]] {fortran_attrs = #fir.var_attrs<host_assoc>, uniq_name = "_QFtest_assumed_rankEx"} : (!fir.box<!fir.array<*:f32>>) -> (!fir.box<!fir.array<*:f32>>, !fir.box<!fir.array<*:f32>>)
37+
! CHECK: fir.call @_QPsome_sub(%[[VAL_5]]#0) fastmath<contract> : (!fir.box<!fir.array<*:f32>>) -> ()
38+
! CHECK: return
39+
! CHECK: }
40+
41+
42+
subroutine test_assumed_rank_optional(x)
43+
class(*), optional :: x(..)
44+
interface
45+
subroutine some_sub2(x)
46+
class(*) :: x(..)
47+
end subroutine
48+
end interface
49+
call internal()
50+
contains
51+
subroutine internal()
52+
call some_sub2(x)
53+
end subroutine
54+
end subroutine
55+
! CHECK-LABEL: func.func @_QPtest_assumed_rank_optional(
56+
! CHECK-SAME: %[[VAL_0:.*]]: !fir.class<!fir.array<*:none>> {fir.bindc_name = "x", fir.optional}) {
57+
! CHECK: %[[VAL_1:.*]] = fir.dummy_scope : !fir.dscope
58+
! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0]] dummy_scope %[[VAL_1]] {fortran_attrs = #fir.var_attrs<optional>, uniq_name = "_QFtest_assumed_rank_optionalEx"} : (!fir.class<!fir.array<*:none>>, !fir.dscope) -> (!fir.class<!fir.array<*:none>>, !fir.class<!fir.array<*:none>>)
59+
! CHECK: %[[VAL_3:.*]] = fir.alloca tuple<!fir.class<!fir.array<*:none>>>
60+
! CHECK: %[[VAL_4:.*]] = arith.constant 0 : i32
61+
! CHECK: %[[VAL_5:.*]] = fir.coordinate_of %[[VAL_3]], %[[VAL_4]] : (!fir.ref<tuple<!fir.class<!fir.array<*:none>>>>, i32) -> !fir.ref<!fir.class<!fir.array<*:none>>>
62+
! CHECK: %[[VAL_6:.*]] = fir.is_present %[[VAL_2]]#0 : (!fir.class<!fir.array<*:none>>) -> i1
63+
! CHECK: fir.if %[[VAL_6]] {
64+
! CHECK: %[[VAL_7:.*]] = fir.rebox_assumed_rank %[[VAL_2]]#0 lbs preserve : (!fir.class<!fir.array<*:none>>) -> !fir.class<!fir.array<*:none>>
65+
! CHECK: fir.store %[[VAL_7]] to %[[VAL_5]] : !fir.ref<!fir.class<!fir.array<*:none>>>
66+
! CHECK: } else {
67+
! CHECK: %[[VAL_8:.*]] = fir.zero_bits !fir.ref<none>
68+
! CHECK: %[[VAL_9:.*]] = fir.embox %[[VAL_8]] : (!fir.ref<none>) -> !fir.class<none>
69+
! CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_9]] : (!fir.class<none>) -> !fir.class<!fir.array<*:none>>
70+
! CHECK: fir.store %[[VAL_10]] to %[[VAL_5]] : !fir.ref<!fir.class<!fir.array<*:none>>>
71+
! CHECK: }
72+
! CHECK: fir.call @_QFtest_assumed_rank_optionalPinternal(%[[VAL_3]]) fastmath<contract> : (!fir.ref<tuple<!fir.class<!fir.array<*:none>>>>) -> ()
73+
! CHECK: return
74+
! CHECK: }
75+
76+
! CHECK-LABEL: func.func private @_QFtest_assumed_rank_optionalPinternal(
77+
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<tuple<!fir.class<!fir.array<*:none>>>> {fir.host_assoc})
78+
! CHECK: %[[VAL_1:.*]] = fir.dummy_scope : !fir.dscope
79+
! CHECK: %[[VAL_2:.*]] = arith.constant 0 : i32
80+
! CHECK: %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_2]] : (!fir.ref<tuple<!fir.class<!fir.array<*:none>>>>, i32) -> !fir.ref<!fir.class<!fir.array<*:none>>>
81+
! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_3]] : !fir.ref<!fir.class<!fir.array<*:none>>>
82+
! CHECK: %[[VAL_5:.*]] = fir.box_addr %[[VAL_4]] : (!fir.class<!fir.array<*:none>>) -> !fir.ref<!fir.array<*:none>>
83+
! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (!fir.ref<!fir.array<*:none>>) -> i64
84+
! CHECK: %[[VAL_7:.*]] = arith.constant 0 : i64
85+
! CHECK: %[[VAL_8:.*]] = arith.cmpi ne, %[[VAL_6]], %[[VAL_7]] : i64
86+
! CHECK: %[[VAL_9:.*]] = fir.absent !fir.class<!fir.array<*:none>>
87+
! CHECK: %[[VAL_10:.*]] = arith.select %[[VAL_8]], %[[VAL_4]], %[[VAL_9]] : !fir.class<!fir.array<*:none>>
88+
! CHECK: %[[VAL_11:.*]]:2 = hlfir.declare %[[VAL_10]] {fortran_attrs = #fir.var_attrs<optional, host_assoc>, uniq_name = "_QFtest_assumed_rank_optionalEx"} : (!fir.class<!fir.array<*:none>>) -> (!fir.class<!fir.array<*:none>>, !fir.class<!fir.array<*:none>>)
89+
! CHECK: fir.call @_QPsome_sub2(%[[VAL_11]]#0) fastmath<contract> : (!fir.class<!fir.array<*:none>>) -> ()
90+
! CHECK: return
91+
! CHECK: }
92+
93+
94+
subroutine test_assumed_rank_ptr(x)
95+
real, pointer :: x(..)
96+
interface
97+
subroutine some_sub3(x)
98+
real, pointer :: x(..)
99+
end subroutine
100+
end interface
101+
call internal()
102+
contains
103+
subroutine internal()
104+
call some_sub3(x)
105+
end subroutine
106+
end subroutine
107+
! CHECK-LABEL: func.func @_QPtest_assumed_rank_ptr(
108+
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>> {fir.bindc_name = "x"}) {
109+
! CHECK: %[[VAL_1:.*]] = fir.dummy_scope : !fir.dscope
110+
! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0]] dummy_scope %[[VAL_1]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFtest_assumed_rank_ptrEx"} : (!fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>, !fir.dscope) -> (!fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>, !fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>)
111+
! CHECK: %[[VAL_3:.*]] = fir.alloca tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>>
112+
! CHECK: %[[VAL_4:.*]] = arith.constant 0 : i32
113+
! CHECK: %[[VAL_5:.*]] = fir.coordinate_of %[[VAL_3]], %[[VAL_4]] : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>>
114+
! CHECK: fir.store %[[VAL_2]]#0 to %[[VAL_5]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>>
115+
! CHECK: fir.call @_QFtest_assumed_rank_ptrPinternal(%[[VAL_3]]) fastmath<contract> : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>>>) -> ()
116+
! CHECK: return
117+
! CHECK: }
118+
119+
! CHECK-LABEL: func.func private @_QFtest_assumed_rank_ptrPinternal(
120+
! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>>> {fir.host_assoc})
121+
! CHECK: %[[VAL_1:.*]] = fir.dummy_scope : !fir.dscope
122+
! CHECK: %[[VAL_2:.*]] = arith.constant 0 : i32
123+
! CHECK: %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_2]] : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>>>, i32) -> !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>>
124+
! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_3]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>>
125+
! CHECK: %[[VAL_5:.*]]:2 = hlfir.declare %[[VAL_4]] {fortran_attrs = #fir.var_attrs<pointer, host_assoc>, uniq_name = "_QFtest_assumed_rank_ptrEx"} : (!fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>) -> (!fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>, !fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>)
126+
! CHECK: fir.call @_QPsome_sub3(%[[VAL_5]]#0) fastmath<contract> : (!fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>) -> ()
127+
! CHECK: return
128+
! CHECK: }

0 commit comments

Comments
 (0)