[flang-commits] [flang] 7f0074a - [flang] Avoid double finalization when intrinsic assignment is done in the runtime
Valentin Clement via flang-commits
flang-commits at lists.llvm.org
Fri Feb 3 03:22:36 PST 2023
Author: Valentin Clement
Date: 2023-02-03T12:22:30+01:00
New Revision: 7f0074a64a30c448fec2f36d08dffbe64134e84d
URL: https://github.com/llvm/llvm-project/commit/7f0074a64a30c448fec2f36d08dffbe64134e84d
DIFF: https://github.com/llvm/llvm-project/commit/7f0074a64a30c448fec2f36d08dffbe64134e84d.diff
LOG: [flang] Avoid double finalization when intrinsic assignment is done in the runtime
genRecordAssignment is emitting code to call Assign in the runtime for some cases.
In these cases, the finalization is done by the runtime so we do not need to do it in
a separate cal to avoid multiple finalization..
Also refactor the code in Bridge so the actual finalization of allocatable
is done before any reallocation. We might need to push this into ReallocIfNeeded.
It is not clear if the allocatable lhs needs to be finalized in any cases or only if it is
reallocated.
Reviewed By: jeanPerier
Differential Revision: https://reviews.llvm.org/D143186
Added:
Modified:
flang/include/flang/Optimizer/Builder/FIRBuilder.h
flang/lib/Lower/Bridge.cpp
flang/lib/Optimizer/Builder/FIRBuilder.cpp
flang/test/Lower/derived-type-finalization.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Optimizer/Builder/FIRBuilder.h b/flang/include/flang/Optimizer/Builder/FIRBuilder.h
index 5e32a1bcc7345..3404d5e092d66 100644
--- a/flang/include/flang/Optimizer/Builder/FIRBuilder.h
+++ b/flang/include/flang/Optimizer/Builder/FIRBuilder.h
@@ -29,6 +29,7 @@
namespace fir {
class AbstractArrayBox;
class ExtendedValue;
+class MutableBoxValue;
class BoxValue;
//===----------------------------------------------------------------------===//
@@ -573,7 +574,8 @@ void genScalarAssignment(fir::FirOpBuilder &builder, mlir::Location loc,
/// derived types (10.2.1.3 point 13).
void genRecordAssignment(fir::FirOpBuilder &builder, mlir::Location loc,
const fir::ExtendedValue &lhs,
- const fir::ExtendedValue &rhs);
+ const fir::ExtendedValue &rhs,
+ bool needFinalization = false);
/// Builds and returns the type of a ragged array header used to cache mask
/// evaluations. RaggedArrayHeader is defined in
diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp
index aa844e592dde1..578553934ee11 100644
--- a/flang/lib/Lower/Bridge.cpp
+++ b/flang/lib/Lower/Bridge.cpp
@@ -2813,33 +2813,32 @@ class FirConverter : public Fortran::lower::AbstractConverter {
std::optional<fir::factory::MutableBoxReallocation> lhsRealloc;
std::optional<fir::MutableBoxValue> lhsMutableBox;
- // Finalize LHS on intrinsic assignment.
- if (lhsType->IsPolymorphic() ||
- lhsType->IsUnlimitedPolymorphic() ||
- (isDerivedCategory(lhsType->category()) &&
- Fortran::semantics::IsFinalizable(
- lhsType->GetDerivedTypeSpec()))) {
- if (lhsIsWholeAllocatable) {
- lhsMutableBox = genExprMutableBox(loc, assign.lhs);
- mlir::Value isAllocated =
- fir::factory::genIsAllocatedOrAssociatedTest(
- *builder, loc, *lhsMutableBox);
- builder->genIfThen(loc, isAllocated)
- .genThen([&]() {
- fir::runtime::genDerivedTypeDestroy(
- *builder, loc, fir::getBase(*lhsMutableBox));
- })
- .end();
- } else {
- fir::ExtendedValue exv = genExprBox(loc, assign.lhs, stmtCtx);
- fir::runtime::genDerivedTypeDestroy(*builder, loc,
- fir::getBase(exv));
- }
- }
+ // Set flag to know if the LHS needs finalization. Polymorphic,
+ // unlimited polymorphic assignment will be done with genAssign.
+ // Assign runtime function performs the finalization.
+ bool needFinalization = !lhsType->IsPolymorphic() &&
+ !lhsType->IsUnlimitedPolymorphic() &&
+ (isDerivedCategory(lhsType->category()) &&
+ Fortran::semantics::IsFinalizable(
+ lhsType->GetDerivedTypeSpec()));
auto lhs = [&]() -> fir::ExtendedValue {
if (lhsIsWholeAllocatable) {
lhsMutableBox = genExprMutableBox(loc, assign.lhs);
+ // Finalize if needed.
+ if (needFinalization) {
+ mlir::Value isAllocated =
+ fir::factory::genIsAllocatedOrAssociatedTest(
+ *builder, loc, *lhsMutableBox);
+ builder->genIfThen(loc, isAllocated)
+ .genThen([&]() {
+ fir::runtime::genDerivedTypeDestroy(
+ *builder, loc, fir::getBase(*lhsMutableBox));
+ })
+ .end();
+ needFinalization = false;
+ }
+
llvm::SmallVector<mlir::Value> lengthParams;
if (const fir::CharBoxValue *charBox = rhs.getCharBox())
lengthParams.push_back(charBox->getLen());
@@ -2882,7 +2881,8 @@ class FirConverter : public Fortran::lower::AbstractConverter {
} else if (isDerivedCategory(lhsType->category())) {
// Fortran 2018 10.2.1.3 p13 and p14
// Recursively gen an assignment on each element pair.
- fir::factory::genRecordAssignment(*builder, loc, lhs, rhs);
+ fir::factory::genRecordAssignment(*builder, loc, lhs, rhs,
+ needFinalization);
} else {
llvm_unreachable("unknown category");
}
diff --git a/flang/lib/Optimizer/Builder/FIRBuilder.cpp b/flang/lib/Optimizer/Builder/FIRBuilder.cpp
index cac5c09ce35c0..caf9f73895b78 100644
--- a/flang/lib/Optimizer/Builder/FIRBuilder.cpp
+++ b/flang/lib/Optimizer/Builder/FIRBuilder.cpp
@@ -12,6 +12,7 @@
#include "flang/Optimizer/Builder/Complex.h"
#include "flang/Optimizer/Builder/MutableBox.h"
#include "flang/Optimizer/Builder/Runtime/Assign.h"
+#include "flang/Optimizer/Builder/Runtime/Derived.h"
#include "flang/Optimizer/Builder/Todo.h"
#include "flang/Optimizer/Dialect/FIRAttr.h"
#include "flang/Optimizer/Dialect/FIROpsSupport.h"
@@ -1205,7 +1206,8 @@ static bool recordTypeCanBeMemCopied(fir::RecordType recordType) {
void fir::factory::genRecordAssignment(fir::FirOpBuilder &builder,
mlir::Location loc,
const fir::ExtendedValue &lhs,
- const fir::ExtendedValue &rhs) {
+ const fir::ExtendedValue &rhs,
+ bool needFinalization) {
assert(lhs.rank() == 0 && rhs.rank() == 0 && "assume scalar assignment");
auto baseTy = fir::dyn_cast_ptrOrBoxEleTy(fir::getBase(lhs).getType());
assert(baseTy && "must be a memory type");
@@ -1229,6 +1231,13 @@ void fir::factory::genRecordAssignment(fir::FirOpBuilder &builder,
fir::runtime::genAssign(builder, loc, toMutableBox, from);
return;
}
+
+ // Finalize LHS on intrinsic assignment.
+ if (needFinalization) {
+ mlir::Value box = builder.createBox(loc, lhs);
+ fir::runtime::genDerivedTypeDestroy(builder, loc, box);
+ }
+
// Otherwise, the derived type has compile time constant size and for which
// the component by component assignment can be replaced by a memory copy.
// Since we do not know the size of the derived type in lowering, do a
diff --git a/flang/test/Lower/derived-type-finalization.f90 b/flang/test/Lower/derived-type-finalization.f90
index 7c117fc7cd762..d2280be81b3e9 100644
--- a/flang/test/Lower/derived-type-finalization.f90
+++ b/flang/test/Lower/derived-type-finalization.f90
@@ -12,12 +12,26 @@ module derived_type_finalization
final :: t1_final
end type
+ type :: t2
+ integer, allocatable, dimension(:) :: a
+ contains
+ final :: t2_final
+ end type
+
+ type :: t3
+ type(t2) :: t
+ end type
+
contains
subroutine t1_final(this)
type(t1) :: this
end subroutine
+ subroutine t2_final(this)
+ type(t2) :: this
+ end subroutine
+
! 7.5.6.3 point 1. Finalization of LHS.
subroutine test_lhs()
type(t1) :: lhs, rhs
@@ -168,6 +182,27 @@ subroutine test_nonpointer_function()
! CHECK: %{{.*}} = fir.call @_FortranAioEndIoStatement
! CHECK: return
+ subroutine test_avoid_double_finalization(a)
+ type(t3), intent(inout) :: a
+ type(t3) :: b
+ b = a
+ end subroutine
+
+! CHECK-LABEL: func.func @_QMderived_type_finalizationPtest_avoid_double_finalization(
+! CHECK: fir.call @_FortranAInitialize(
+! CHECK-NOT: %{{.*}} = fir.call @_FortranADestroy
+! CHECK: %{{.*}} = fir.call @_FortranAAssign(
+! CHECK: %{{.*}} = fir.call @_FortranADestroy(
+
+ function no_func_ret_finalize() result(ty)
+ type(t1) :: ty
+ ty = t1(10)
+ end function
+
+! CHECK-LABEL: func.func @_QMderived_type_finalizationPno_func_ret_finalize() -> !fir.type<_QMderived_type_finalizationTt1{a:i32}> {
+! CHECK: %{{.*}} = fir.call @_FortranADestroy
+! CHECK: return %{{.*}} : !fir.type<_QMderived_type_finalizationTt1{a:i32}>
+
end module
program p
More information about the flang-commits
mailing list