Skip to content

[flang] lower assumed-ranks captured in internal procedures #96106

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 1 commit into from
Jun 20, 2024
Merged

[flang] lower assumed-ranks captured in internal procedures #96106

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
7 changes: 4 additions & 3 deletions flang/lib/Lower/ConvertType.cpp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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))
Expand Down
10 changes: 6 additions & 4 deletions flang/lib/Lower/HostAssociations.cpp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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.
Expand Down Expand Up @@ -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));
Expand Down Expand Up @@ -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
Expand All @@ -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);
Expand Down
20 changes: 17 additions & 3 deletions flang/lib/Optimizer/Builder/MutableBox.cpp
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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);
Expand Down Expand Up @@ -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(
Expand Down
128 changes: 128 additions & 0 deletions flang/test/Lower/HLFIR/assumed-rank-internal-proc.f90
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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: }
Loading