Skip to content

Commit

Permalink
[flang] Deallocate local allocatable at end of their scopes (llvm#67036)
Browse files Browse the repository at this point in the history 
Implement automatic deallocation of unsaved local alloctables when
reaching the end of their scope of block as described in Fortran 2018
9.7.3.2 point 2. and 3.

Uses genDeallocateIfAllocated used for intent(out) deallocation and the
"function context" already used for finalization at end of scope.
  • Loading branch information
@jeanPerier
jeanPerier authored Sep 22, 2023
1 parent 22f423a commit 0c7d0ad
Show file tree
Hide file tree
Showing 3 changed files with 276 additions and 20 deletions.
51 changes: 35 additions & 16 deletions flang/lib/Lower/ConvertVariable.cpp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -652,26 +652,30 @@ defaultInitializeAtRuntime(Fortran::lower::AbstractConverter &converter,
}
}

/// Check whether a variable needs to be finalized according to clause 7.5.6.3
/// point 3.
/// Must be nonpointer, nonallocatable object that is not a dummy argument or
/// function result.
static bool needEndFinalization(const Fortran::lower::pft::Variable &var) {
enum class VariableCleanUp { Finalize, Deallocate };
/// Check whether a local variable needs to be finalized according to clause
/// 7.5.6.3 point 3 or if it is an allocatable that must be deallocated. Note
/// that deallocation will trigger finalization if the type has any.
static std::optional<VariableCleanUp>
needDeallocationOrFinalization(const Fortran::lower::pft::Variable &var) {
if (!var.hasSymbol())
return false;
return std::nullopt;
const Fortran::semantics::Symbol &sym = var.getSymbol();
const Fortran::semantics::Scope &owner = sym.owner();
if (owner.kind() == Fortran::semantics::Scope::Kind::MainProgram) {
// The standard does not require finalizing main program variables.
return false;
return std::nullopt;
}
if (!Fortran::semantics::IsPointer(sym) &&
!Fortran::semantics::IsAllocatable(sym) &&
!Fortran::semantics::IsDummy(sym) &&
!Fortran::semantics::IsFunctionResult(sym) &&
!Fortran::semantics::IsSaved(sym))
return hasFinalization(sym);
return false;
!Fortran::semantics::IsSaved(sym)) {
if (Fortran::semantics::IsAllocatable(sym))
return VariableCleanUp::Deallocate;
if (hasFinalization(sym))
return VariableCleanUp::Finalize;
}
return std::nullopt;
}

/// Check whether a variable needs the be finalized according to clause 7.5.6.3
Expand Down Expand Up @@ -779,15 +783,30 @@ static void instantiateLocal(Fortran::lower::AbstractConverter &converter,
finalizeAtRuntime(converter, var, symMap);
if (mustBeDefaultInitializedAtRuntime(var))
defaultInitializeAtRuntime(converter, var, symMap);
if (needEndFinalization(var)) {
if (std::optional<VariableCleanUp> cleanup =
needDeallocationOrFinalization(var)) {
auto *builder = &converter.getFirOpBuilder();
mlir::Location loc = converter.getCurrentLocation();
fir::ExtendedValue exv =
converter.getSymbolExtendedValue(var.getSymbol(), &symMap);
converter.getFctCtx().attachCleanup([builder, loc, exv]() {
mlir::Value box = builder->createBox(loc, exv);
fir::runtime::genDerivedTypeDestroy(*builder, loc, box);
});
switch (*cleanup) {
case VariableCleanUp::Finalize:
converter.getFctCtx().attachCleanup([builder, loc, exv]() {
mlir::Value box = builder->createBox(loc, exv);
fir::runtime::genDerivedTypeDestroy(*builder, loc, box);
});
break;
case VariableCleanUp::Deallocate:
auto *converterPtr = &converter;
converter.getFctCtx().attachCleanup([converterPtr, loc, exv]() {
const fir::MutableBoxValue *mutableBox =
exv.getBoxOf<fir::MutableBoxValue>();
assert(mutableBox &&
"trying to deallocate entity not lowered as allocatable");
Fortran::lower::genDeallocateIfAllocated(*converterPtr, *mutableBox,
loc);
});
}
}
}

Expand Down
239 changes: 239 additions & 0 deletions flang/test/Lower/HLFIR/allocatable-end-of-scope-dealloc.f90
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,239 @@
! Test automatic deallocation of local allocatables as described in
! Fortran 2018 standard 9.7.3.2 point 2. and 3.

! RUN: bbc -emit-hlfir -o - %s | FileCheck %s
module dtypedef
type must_finalize
integer :: i
contains
final :: finalize
end type
type contain_must_finalize
type(must_finalize) :: a
end type
interface
subroutine finalize(a)
import :: must_finalize
type(must_finalize), intent(inout) :: a
end subroutine
end interface
real, allocatable :: x
end module

subroutine simple()
real, allocatable :: x
allocate(x)
call bar()
end subroutine
! CHECK-LABEL: func.func @_QPsimple() {
! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare {{.*}}"_QFsimpleEx"
! CHECK: fir.call @_QPbar
! CHECK: %[[VAL_6:.*]] = fir.load %[[VAL_3]]#1 : !fir.ref<!fir.box<!fir.heap<f32>>>
! CHECK: %[[VAL_7:.*]] = fir.box_addr %[[VAL_6]] : (!fir.box<!fir.heap<f32>>) -> !fir.heap<f32>
! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (!fir.heap<f32>) -> i64
! CHECK: %[[VAL_9:.*]] = arith.constant 0 : i64
! CHECK: %[[VAL_10:.*]] = arith.cmpi ne, %[[VAL_8]], %[[VAL_9]] : i64
! CHECK: fir.if %[[VAL_10]] {
! CHECK: %[[VAL_11:.*]] = fir.load %[[VAL_3]]#1 : !fir.ref<!fir.box<!fir.heap<f32>>>
! CHECK: %[[VAL_12:.*]] = fir.box_addr %[[VAL_11]] : (!fir.box<!fir.heap<f32>>) -> !fir.heap<f32>
! CHECK: fir.freemem %[[VAL_12]] : !fir.heap<f32>
! CHECK: %[[VAL_13:.*]] = fir.zero_bits !fir.heap<f32>
! CHECK: %[[VAL_14:.*]] = fir.embox %[[VAL_13]] : (!fir.heap<f32>) -> !fir.box<!fir.heap<f32>>
! CHECK: fir.store %[[VAL_14]] to %[[VAL_3]]#1 : !fir.ref<!fir.box<!fir.heap<f32>>>
! CHECK: }

subroutine multiple_return(cdt)
real, allocatable :: x
logical :: cdt
allocate(x)
if (cdt) return
call bar()
end subroutine
! CHECK-LABEL: func.func @_QPmultiple_return(
! CHECK: cf.cond_br %{{.*}}, ^bb1, ^bb2
! CHECK: ^bb1:
! CHECK-NOT: fir.freemem
! CHECK: cf.br ^bb3
! CHECK: ^bb2:
! CHECK: fir.call @_QPbar
! CHECK: cf.br ^bb3
! CHECK: ^bb3:
! CHECK: fir.if {{.*}} {
! CHECK: fir.freemem
! CHECK: }
! CHECK: return

subroutine derived()
use dtypedef, only : must_finalize
type(must_finalize), allocatable :: x
allocate(x)
call bar()
end subroutine
! CHECK-LABEL: func.func @_QPderived() {
! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare {{.*}}"_QFderivedEx"
! CHECK: fir.call @_QPbar
! CHECK: %[[VAL_11:.*]] = fir.load %[[VAL_3]]#1 : !fir.ref<!fir.box<!fir.heap<!fir.type<_QMdtypedefTmust_finalize{i:i32}>>>>
! CHECK: %[[VAL_12:.*]] = fir.box_addr %[[VAL_11]] : (!fir.box<!fir.heap<!fir.type<_QMdtypedefTmust_finalize{i:i32}>>>) -> !fir.heap<!fir.type<_QMdtypedefTmust_finalize{i:i32}>>
! CHECK: %[[VAL_13:.*]] = fir.convert %[[VAL_12]] : (!fir.heap<!fir.type<_QMdtypedefTmust_finalize{i:i32}>>) -> i64
! CHECK: %[[VAL_14:.*]] = arith.constant 0 : i64
! CHECK: %[[VAL_15:.*]] = arith.cmpi ne, %[[VAL_13]], %[[VAL_14]] : i64
! CHECK: fir.if %[[VAL_15]] {
! CHECK: %[[VAL_16:.*]] = arith.constant false
! CHECK: %[[VAL_17:.*]] = fir.absent !fir.box<none>
! CHECK: %[[VAL_20:.*]] = fir.convert %[[VAL_3]]#1 : (!fir.ref<!fir.box<!fir.heap<!fir.type<_QMdtypedefTmust_finalize{i:i32}>>>>) -> !fir.ref<!fir.box<none>>
! CHECK: %[[VAL_22:.*]] = fir.call @_FortranAAllocatableDeallocate(%[[VAL_20]], %[[VAL_16]], %[[VAL_17]], %{{.*}}, %{{.*}})
! CHECK: }

subroutine derived2()
use dtypedef, only : contain_must_finalize
type(contain_must_finalize), allocatable :: x
allocate(x)
end subroutine
! CHECK-LABEL: func.func @_QPderived2(
! CHECK: fir.if {{.*}} {
! CHECK: fir.call @_FortranAAllocatableDeallocate
! CHECK: }

subroutine simple_block()
block
real, allocatable :: x
allocate(x)
call bar()
end block
call bar_after_block()
end subroutine
! CHECK-LABEL: func.func @_QPsimple_block(
! CHECK: fir.call @_QPbar
! CHECK: fir.if {{.*}} {
! CHECK: fir.freemem
! CHECK: }
! CHECK: fir.call @_QPbar_after_block

subroutine mutiple_return_block(cdt)
logical :: cdt
block
real, allocatable :: x
allocate(x)
if (cdt) return
call bar()
end block
call bar_after_block()
end subroutine
! CHECK-LABEL: func.func @_QPmutiple_return_block(
! CHECK: cf.cond_br %{{.*}}, ^bb1, ^bb2
! CHECK: ^bb1:
! CHECK: fir.if {{.*}} {
! CHECK: fir.freemem
! CHECK: }
! CHECK: cf.br ^bb3
! CHECK: ^bb2:
! CHECK: fir.call @_QPbar
! CHECK: fir.if {{.*}} {
! CHECK: fir.freemem
! CHECK: }
! CHECK: fir.call @_QPbar_after_block
! CHECK: cf.br ^bb3
! CHECK: ^bb3:
! CHECK: return


subroutine derived_block()
use dtypedef, only : must_finalize
block
type(must_finalize), allocatable :: x
allocate(x)
call bar()
end block
call bar_after_block()
end subroutine
! CHECK-LABEL: func.func @_QPderived_block(
! CHECK: fir.call @_QPbar
! CHECK: fir.if {{.*}} {
! CHECK: fir.call @_FortranAAllocatableDeallocate
! CHECK: }
! CHECK: fir.call @_QPbar_after_block

subroutine derived_block2()
use dtypedef, only : contain_must_finalize
call bar()
block
type(contain_must_finalize), allocatable :: x
allocate(x)
end block
call bar_after_block()
end subroutine
! CHECK-LABEL: func.func @_QPderived_block2(
! CHECK: fir.call @_QPbar
! CHECK: fir.if {{.*}} {
! CHECK: fir.call @_FortranAAllocatableDeallocate
! CHECK: }
! CHECK: fir.call @_QPbar_after_block

subroutine no_dealloc_saved()
real, allocatable, save :: x
allocate(x)
end subroutine
! CHECK-LABEL: func.func @_QPno_dealloc_save
! CHECK-NOT: freemem
! CHECK-NOT: Deallocate
! CHECK: return

subroutine no_dealloc_block_saved()
block
real, allocatable, save :: x
allocate(x)
end block
end subroutine
! CHECK-LABEL: func.func @_QPno_dealloc_block_saved
! CHECK-NOT: freemem
! CHECK-NOT: Deallocate
! CHECK: return

function no_dealloc_result() result(x)
real, allocatable :: x
allocate(x)
end function
! CHECK-LABEL: func.func @_QPno_dealloc_result
! CHECK-NOT: freemem
! CHECK-NOT: Deallocate
! CHECK: return

subroutine no_dealloc_dummy(x)
real, allocatable :: x
allocate(x)
end subroutine
! CHECK-LABEL: func.func @_QPno_dealloc_dummy
! CHECK-NOT: freemem
! CHECK-NOT: Deallocate
! CHECK: return

subroutine no_dealloc_module_var()
use dtypedef, only : x
allocate(x)
end subroutine
! CHECK-LABEL: func.func @_QPno_dealloc_module_var
! CHECK-NOT: freemem
! CHECK-NOT: Deallocate
! CHECK: return

subroutine no_dealloc_host_assoc()
real, allocatable :: x
call internal()
contains
subroutine internal()
allocate(x)
end subroutine
end subroutine
! CHECK-LABEL: func.func @_QFno_dealloc_host_assocPinternal
! CHECK-NOT: freemem
! CHECK-NOT: Deallocate
! CHECK: return

subroutine no_dealloc_pointer(x)
real, pointer :: x
allocate(x)
end subroutine
! CHECK-LABEL: func.func @_QPno_dealloc_pointer
! CHECK-NOT: freemem
! CHECK-NOT: Deallocate
! CHECK: return
6 changes: 2 additions & 4 deletions flang/test/Lower/allocatable-polymorphic.f90
View file
Original file line number Diff line number Diff line change
Expand Up @@ -656,11 +656,9 @@ program test_alloc
! allocatable.

! LLVM-LABEL: define void @_QMpolyPtest_deallocate()
! LLVM: %[[ALLOCA1:.*]] = alloca { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] }
! LLVM: %[[ALLOCA2:.*]] = alloca { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] }, i64 1
! LLVM: store { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } { ptr null, i64 ptrtoint (ptr getelementptr (%_QMpolyTp1, ptr null, i32 1) to i64), i32 20180515, i8 0, i8 42, i8 2, i8 1, ptr @_QMpolyE.dt.p1, [1 x i64] undef }, ptr %[[ALLOCA1]]
! LLVM: store { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } { ptr null, i64 ptrtoint (ptr getelementptr (%_QMpolyTp1, ptr null, i32 1) to i64), i32 20180515, i8 0, i8 42, i8 2, i8 1, ptr @_QMpolyE.dt.p1, [1 x i64] undef }, ptr %[[ALLOCA1:[0-9]*]]
! LLVM: %[[LOAD:.*]] = load { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] }, ptr %[[ALLOCA1]]
! LLVM: store { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[LOAD]], ptr %[[ALLOCA2]]
! LLVM: store { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[LOAD]], ptr %[[ALLOCA2:[0-9]*]]
! LLVM: %{{.*}} = call {} @_FortranAAllocatableInitDerivedForAllocate(ptr %[[ALLOCA2]], ptr @_QMpolyE.dt.p1, i32 0, i32 0)
! LLVM: %{{.*}} = call i32 @_FortranAAllocatableAllocate(ptr %[[ALLOCA2]], i1 false, ptr null, ptr @_QQcl.{{.*}}, i32 {{.*}})
! LLVM: %{{.*}} = call i32 @_FortranAAllocatableDeallocatePolymorphic(ptr %[[ALLOCA2]], ptr {{.*}}, i1 false, ptr null, ptr @_QQcl.{{.*}}, i32 {{.*}})

0 comments on commit 0c7d0ad

Please sign in to comment.