[flang-commits] [flang] [flang] lower assumed-ranks captured in internal procedures (PR #96106)
via flang-commits
flang-commits at lists.llvm.org
Thu Jun 20 00:34:55 PDT 2024
https://github.com/jeanPerier updated https://github.com/llvm/llvm-project/pull/96106
>From 837078589890abf968a3b69d1181e64f95b93811 Mon Sep 17 00:00:00 2001
From: Jean Perier <jperier at nvidia.com>
Date: Wed, 19 Jun 2024 12:37:00 -0700
Subject: [PATCH] [flang] lower assumed-ranks captured in internal procedures
---
flang/lib/Lower/ConvertType.cpp | 7 +-
flang/lib/Lower/HostAssociations.cpp | 10 +-
flang/lib/Optimizer/Builder/MutableBox.cpp | 20 ++-
.../HLFIR/assumed-rank-internal-proc.f90 | 128 ++++++++++++++++++
4 files changed, 155 insertions(+), 10 deletions(-)
create mode 100644 flang/test/Lower/HLFIR/assumed-rank-internal-proc.f90
diff --git a/flang/lib/Lower/ConvertType.cpp b/flang/lib/Lower/ConvertType.cpp
index f64f6c93541a3..a47fc99ea9f45 100644
--- a/flang/lib/Lower/ConvertType.cpp
+++ b/flang/lib/Lower/ConvertType.cpp
@@ -280,10 +280,11 @@ struct TypeBuilderImpl {
if (ultimate.IsObjectArray()) {
auto shapeExpr =
Fortran::evaluate::GetShape(converter.getFoldingContext(), ultimate);
- if (!shapeExpr)
- TODO(loc, "assumed rank symbol type");
fir::SequenceType::Shape shape;
- translateShape(shape, std::move(*shapeExpr));
+ // If there is no shapExpr, this is an assumed-rank, and the empty shape
+ // will build the desired fir.array<*:T> type.
+ if (shapeExpr)
+ translateShape(shape, std::move(*shapeExpr));
ty = fir::SequenceType::get(shape, ty);
}
if (Fortran::semantics::IsPointer(symbol))
diff --git a/flang/lib/Lower/HostAssociations.cpp b/flang/lib/Lower/HostAssociations.cpp
index 75a5bed566557..0f75a8a7c312e 100644
--- a/flang/lib/Lower/HostAssociations.cpp
+++ b/flang/lib/Lower/HostAssociations.cpp
@@ -366,7 +366,8 @@ class CapturedAllocatableAndPointer
}
};
-/// Class defining how arrays are captured inside internal procedures.
+/// Class defining how arrays, including assumed-ranks, are captured inside
+/// internal procedures.
/// Array are captured via a `fir.box<fir.array<T>>` descriptor that belongs to
/// the host tuple. This allows capturing lower bounds, which can be done by
/// providing a ShapeShiftOp argument to the EmboxOp.
@@ -430,7 +431,7 @@ class CapturedArrays : public CapturedSymbols<CapturedArrays> {
mlir::Value box = args.valueInTuple;
mlir::IndexType idxTy = builder.getIndexType();
llvm::SmallVector<mlir::Value> lbounds;
- if (!ba.lboundIsAllOnes()) {
+ if (!ba.lboundIsAllOnes() && !Fortran::evaluate::IsAssumedRank(sym)) {
if (ba.isStaticArray()) {
for (std::int64_t lb : ba.staticLBound())
lbounds.emplace_back(builder.createIntegerConstant(loc, idxTy, lb));
@@ -488,7 +489,8 @@ class CapturedArrays : public CapturedSymbols<CapturedArrays> {
const Fortran::semantics::DeclTypeSpec *type = sym.GetType();
bool isPolymorphic = type && type->IsPolymorphic();
return isScalarOrContiguous && !isPolymorphic &&
- !isDerivedWithLenParameters(sym);
+ !isDerivedWithLenParameters(sym) &&
+ !Fortran::evaluate::IsAssumedRank(sym);
}
};
} // namespace
@@ -514,7 +516,7 @@ walkCaptureCategories(T visitor, Fortran::lower::AbstractConverter &converter,
if (Fortran::semantics::IsAllocatableOrPointer(sym) ||
sym.GetUltimate().test(Fortran::semantics::Symbol::Flag::CrayPointee))
return CapturedAllocatableAndPointer::visit(visitor, converter, sym, ba);
- if (ba.isArray())
+ if (ba.isArray()) // include assumed-ranks.
return CapturedArrays::visit(visitor, converter, sym, ba);
if (Fortran::semantics::IsPolymorphic(sym))
return CapturedPolymorphicScalar::visit(visitor, converter, sym, ba);
diff --git a/flang/lib/Optimizer/Builder/MutableBox.cpp b/flang/lib/Optimizer/Builder/MutableBox.cpp
index 52d149fa7b9a0..fcb9ddcf41386 100644
--- a/flang/lib/Optimizer/Builder/MutableBox.cpp
+++ b/flang/lib/Optimizer/Builder/MutableBox.cpp
@@ -329,7 +329,18 @@ class MutablePropertyWriter {
mlir::Value fir::factory::createUnallocatedBox(
fir::FirOpBuilder &builder, mlir::Location loc, mlir::Type boxType,
mlir::ValueRange nonDeferredParams, mlir::Value typeSourceBox) {
- auto baseAddrType = mlir::dyn_cast<fir::BaseBoxType>(boxType).getEleTy();
+ auto baseBoxType = mlir::cast<fir::BaseBoxType>(boxType);
+ // Giving unallocated/disassociated status to assumed-rank POINTER/
+ // ALLOCATABLE is not directly possible to a Fortran user. But the
+ // compiler may need to create such temporary descriptor to deal with
+ // cases like ENTRY or host association. In such case, all that mater
+ // is that the base address is set to zero and the rank is set to
+ // some defined value. Hence, a scalar descriptor is created and
+ // cast to assumed-rank.
+ const bool isAssumedRank = baseBoxType.isAssumedRank();
+ if (isAssumedRank)
+ baseBoxType = baseBoxType.getBoxTypeWithNewShape(/*rank=*/0);
+ auto baseAddrType = baseBoxType.getEleTy();
if (!fir::isa_ref_type(baseAddrType))
baseAddrType = builder.getRefType(baseAddrType);
auto type = fir::unwrapRefType(baseAddrType);
@@ -361,8 +372,11 @@ mlir::Value fir::factory::createUnallocatedBox(
}
}
mlir::Value emptySlice;
- return builder.create<fir::EmboxOp>(loc, boxType, nullAddr, shape, emptySlice,
- lenParams, typeSourceBox);
+ auto embox = builder.create<fir::EmboxOp>(
+ loc, baseBoxType, nullAddr, shape, emptySlice, lenParams, typeSourceBox);
+ if (isAssumedRank)
+ return builder.createConvert(loc, boxType, embox);
+ return embox;
}
fir::MutableBoxValue fir::factory::createTempMutableBox(
diff --git a/flang/test/Lower/HLFIR/assumed-rank-internal-proc.f90 b/flang/test/Lower/HLFIR/assumed-rank-internal-proc.f90
new file mode 100644
index 0000000000000..f8d5e84696c5f
--- /dev/null
+++ b/flang/test/Lower/HLFIR/assumed-rank-internal-proc.f90
@@ -0,0 +1,128 @@
+! Test assumed-rank capture inside internal procedures.
+! RUN: bbc -emit-hlfir -o - %s -allow-assumed-rank | FileCheck %s
+
+subroutine test_assumed_rank(x)
+ real :: x(..)
+interface
+subroutine some_sub(x)
+ real :: x(..)
+end subroutine
+end interface
+ call internal()
+contains
+subroutine internal()
+ call some_sub(x)
+end subroutine
+end subroutine
+! CHECK-LABEL: func.func @_QPtest_assumed_rank(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.box<!fir.array<*:f32>> {fir.bindc_name = "x"}) {
+! CHECK: %[[VAL_1:.*]] = fir.dummy_scope : !fir.dscope
+! 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>>)
+! CHECK: %[[VAL_3:.*]] = fir.alloca tuple<!fir.box<!fir.array<*:f32>>>
+! CHECK: %[[VAL_4:.*]] = arith.constant 0 : i32
+! 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>>>
+! CHECK: %[[VAL_6:.*]] = fir.rebox_assumed_rank %[[VAL_2]]#0 lbs preserve : (!fir.box<!fir.array<*:f32>>) -> !fir.box<!fir.array<*:f32>>
+! CHECK: fir.store %[[VAL_6]] to %[[VAL_5]] : !fir.ref<!fir.box<!fir.array<*:f32>>>
+! CHECK: fir.call @_QFtest_assumed_rankPinternal(%[[VAL_3]]) fastmath<contract> : (!fir.ref<tuple<!fir.box<!fir.array<*:f32>>>>) -> ()
+! CHECK: return
+! CHECK: }
+
+! CHECK-LABEL: func.func private @_QFtest_assumed_rankPinternal(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<tuple<!fir.box<!fir.array<*:f32>>>> {fir.host_assoc})
+! CHECK: %[[VAL_1:.*]] = fir.dummy_scope : !fir.dscope
+! CHECK: %[[VAL_2:.*]] = arith.constant 0 : i32
+! 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>>>
+! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_3]] : !fir.ref<!fir.box<!fir.array<*:f32>>>
+! 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>>)
+! CHECK: fir.call @_QPsome_sub(%[[VAL_5]]#0) fastmath<contract> : (!fir.box<!fir.array<*:f32>>) -> ()
+! CHECK: return
+! CHECK: }
+
+
+subroutine test_assumed_rank_optional(x)
+ class(*), optional :: x(..)
+interface
+subroutine some_sub2(x)
+ class(*) :: x(..)
+end subroutine
+end interface
+ call internal()
+contains
+subroutine internal()
+ call some_sub2(x)
+end subroutine
+end subroutine
+! CHECK-LABEL: func.func @_QPtest_assumed_rank_optional(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.class<!fir.array<*:none>> {fir.bindc_name = "x", fir.optional}) {
+! CHECK: %[[VAL_1:.*]] = fir.dummy_scope : !fir.dscope
+! 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>>)
+! CHECK: %[[VAL_3:.*]] = fir.alloca tuple<!fir.class<!fir.array<*:none>>>
+! CHECK: %[[VAL_4:.*]] = arith.constant 0 : i32
+! 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>>>
+! CHECK: %[[VAL_6:.*]] = fir.is_present %[[VAL_2]]#0 : (!fir.class<!fir.array<*:none>>) -> i1
+! CHECK: fir.if %[[VAL_6]] {
+! CHECK: %[[VAL_7:.*]] = fir.rebox_assumed_rank %[[VAL_2]]#0 lbs preserve : (!fir.class<!fir.array<*:none>>) -> !fir.class<!fir.array<*:none>>
+! CHECK: fir.store %[[VAL_7]] to %[[VAL_5]] : !fir.ref<!fir.class<!fir.array<*:none>>>
+! CHECK: } else {
+! CHECK: %[[VAL_8:.*]] = fir.zero_bits !fir.ref<none>
+! CHECK: %[[VAL_9:.*]] = fir.embox %[[VAL_8]] : (!fir.ref<none>) -> !fir.class<none>
+! CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_9]] : (!fir.class<none>) -> !fir.class<!fir.array<*:none>>
+! CHECK: fir.store %[[VAL_10]] to %[[VAL_5]] : !fir.ref<!fir.class<!fir.array<*:none>>>
+! CHECK: }
+! CHECK: fir.call @_QFtest_assumed_rank_optionalPinternal(%[[VAL_3]]) fastmath<contract> : (!fir.ref<tuple<!fir.class<!fir.array<*:none>>>>) -> ()
+! CHECK: return
+! CHECK: }
+
+! CHECK-LABEL: func.func private @_QFtest_assumed_rank_optionalPinternal(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<tuple<!fir.class<!fir.array<*:none>>>> {fir.host_assoc})
+! CHECK: %[[VAL_1:.*]] = fir.dummy_scope : !fir.dscope
+! CHECK: %[[VAL_2:.*]] = arith.constant 0 : i32
+! 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>>>
+! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_3]] : !fir.ref<!fir.class<!fir.array<*:none>>>
+! CHECK: %[[VAL_5:.*]] = fir.box_addr %[[VAL_4]] : (!fir.class<!fir.array<*:none>>) -> !fir.ref<!fir.array<*:none>>
+! CHECK: %[[VAL_6:.*]] = fir.convert %[[VAL_5]] : (!fir.ref<!fir.array<*:none>>) -> i64
+! CHECK: %[[VAL_7:.*]] = arith.constant 0 : i64
+! CHECK: %[[VAL_8:.*]] = arith.cmpi ne, %[[VAL_6]], %[[VAL_7]] : i64
+! CHECK: %[[VAL_9:.*]] = fir.absent !fir.class<!fir.array<*:none>>
+! CHECK: %[[VAL_10:.*]] = arith.select %[[VAL_8]], %[[VAL_4]], %[[VAL_9]] : !fir.class<!fir.array<*:none>>
+! 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>>)
+! CHECK: fir.call @_QPsome_sub2(%[[VAL_11]]#0) fastmath<contract> : (!fir.class<!fir.array<*:none>>) -> ()
+! CHECK: return
+! CHECK: }
+
+
+subroutine test_assumed_rank_ptr(x)
+ real, pointer :: x(..)
+interface
+subroutine some_sub3(x)
+ real, pointer :: x(..)
+end subroutine
+end interface
+ call internal()
+contains
+subroutine internal()
+ call some_sub3(x)
+end subroutine
+end subroutine
+! CHECK-LABEL: func.func @_QPtest_assumed_rank_ptr(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>> {fir.bindc_name = "x"}) {
+! CHECK: %[[VAL_1:.*]] = fir.dummy_scope : !fir.dscope
+! 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>>>>)
+! CHECK: %[[VAL_3:.*]] = fir.alloca tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>>
+! CHECK: %[[VAL_4:.*]] = arith.constant 0 : i32
+! 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>>>>>
+! CHECK: fir.store %[[VAL_2]]#0 to %[[VAL_5]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>>
+! CHECK: fir.call @_QFtest_assumed_rank_ptrPinternal(%[[VAL_3]]) fastmath<contract> : (!fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>>>) -> ()
+! CHECK: return
+! CHECK: }
+
+! CHECK-LABEL: func.func private @_QFtest_assumed_rank_ptrPinternal(
+! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref<tuple<!fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>>> {fir.host_assoc})
+! CHECK: %[[VAL_1:.*]] = fir.dummy_scope : !fir.dscope
+! CHECK: %[[VAL_2:.*]] = arith.constant 0 : i32
+! 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>>>>>
+! CHECK: %[[VAL_4:.*]] = fir.load %[[VAL_3]] : !fir.llvm_ptr<!fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>>
+! 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>>>>)
+! CHECK: fir.call @_QPsome_sub3(%[[VAL_5]]#0) fastmath<contract> : (!fir.ref<!fir.box<!fir.ptr<!fir.array<*:f32>>>>) -> ()
+! CHECK: return
+! CHECK: }
More information about the flang-commits
mailing list