diff --git a/flang/lib/Optimizer/HLFIR/Transforms/ConvertToFIR.cpp b/flang/lib/Optimizer/HLFIR/Transforms/ConvertToFIR.cpp --- a/flang/lib/Optimizer/HLFIR/Transforms/ConvertToFIR.cpp +++ b/flang/lib/Optimizer/HLFIR/Transforms/ConvertToFIR.cpp @@ -140,14 +140,10 @@ builder.create(loc, to, toMutableBox); fir::runtime::genAssign(builder, loc, toMutableBox, from); } else { - // Assume overlap does not matter for scalar (dealt with memmove for - // characters). - // This is not true if this is a derived type with "recursive" allocatable - // components, in which case an overlap would matter because the LHS - // reallocation, if any, may modify the RHS component value before it is - // copied into the LHS. - if (fir::isRecordWithAllocatableMember(lhs.getFortranElementType())) - TODO(loc, "assignment with allocatable components"); + // genScalarAssignment() must take care of potential overlap + // between LHS and RHS. Note that the overlap is possible + // also for components of LHS/RHS, and the Assign() runtime + // must take care of it. fir::factory::genScalarAssignment(builder, loc, lhsExv, rhsExv); } rewriter.eraseOp(assignOp); diff --git a/flang/runtime/assign.cpp b/flang/runtime/assign.cpp --- a/flang/runtime/assign.cpp +++ b/flang/runtime/assign.cpp @@ -23,7 +23,8 @@ CanBeDefinedAssignment = 1 << 2, ComponentCanBeDefinedAssignment = 1 << 3, ExplicitLengthCharacterLHS = 1 << 4, - PolymorphicLHS = 1 << 5 + PolymorphicLHS = 1 << 5, + DeallocateLHS = 1 << 6 }; // Predicate: is the left-hand side of an assignment an allocated allocatable @@ -249,30 +250,14 @@ // dealing with array constructors. static void Assign( Descriptor &to, const Descriptor &from, Terminator &terminator, int flags) { - bool mustDeallocateLHS{MustDeallocateLHS(to, from, terminator, flags)}; + bool mustDeallocateLHS{(flags & DeallocateLHS) || + MustDeallocateLHS(to, from, terminator, flags)}; DescriptorAddendum *toAddendum{to.Addendum()}; const typeInfo::DerivedType *toDerived{ toAddendum ? toAddendum->derivedType() : nullptr}; - if (toDerived) { - if (flags & CanBeDefinedAssignment) { - // Check for a user-defined assignment type-bound procedure; - // see 10.2.1.4-5. A user-defined assignment TBP defines all of - // the semantics, including allocatable (re)allocation and any - // finalization. - if (to.rank() == 0) { - if (const auto *special{toDerived->FindSpecialBinding( - typeInfo::SpecialBinding::Which::ScalarAssignment)}) { - return DoScalarDefinedAssignment(to, from, *special); - } - } - if (const auto *special{toDerived->FindSpecialBinding( - typeInfo::SpecialBinding::Which::ElementalAssignment)}) { - return DoElementalDefinedAssignment(to, from, *toDerived, *special); - } - } - if ((flags & NeedFinalization) && toDerived->noFinalizationNeeded()) { - flags &= ~NeedFinalization; - } + if (toDerived && (flags & NeedFinalization) && + toDerived->noFinalizationNeeded()) { + flags &= ~NeedFinalization; } std::size_t toElementBytes{to.ElementBytes()}; std::size_t fromElementBytes{from.ElementBytes()}; @@ -315,7 +300,7 @@ Assign(to, newFrom, terminator, flags & (NeedFinalization | ComponentCanBeDefinedAssignment | - ExplicitLengthCharacterLHS)); + ExplicitLengthCharacterLHS | CanBeDefinedAssignment)); newFrom.Deallocate(); } return; @@ -345,6 +330,27 @@ toElementBytes = to.ElementBytes(); // may have changed } } + if (toDerived && (flags & CanBeDefinedAssignment)) { + // Check for a user-defined assignment type-bound procedure; + // see 10.2.1.4-5. A user-defined assignment TBP defines all of + // the semantics, including allocatable (re)allocation and any + // finalization. + // + // Note that the aliasing and LHS (re)allocation handling above + // needs to run even with CanBeDefinedAssignment flag, when + // the Assign() is invoked recursively for component-per-component + // assignments. + if (to.rank() == 0) { + if (const auto *special{toDerived->FindSpecialBinding( + typeInfo::SpecialBinding::Which::ScalarAssignment)}) { + return DoScalarDefinedAssignment(to, from, *special); + } + } + if (const auto *special{toDerived->FindSpecialBinding( + typeInfo::SpecialBinding::Which::ElementalAssignment)}) { + return DoElementalDefinedAssignment(to, from, *toDerived, *special); + } + } SubscriptValue toAt[maxRank]; to.GetLowerBounds(toAt); // Scalar expansion of the RHS is implied by using the same empty @@ -429,32 +435,31 @@ to.Element(toAt) + comp.offset())}; const auto *fromDesc{reinterpret_cast( from.Element(fromAt) + comp.offset())}; + // Allocatable components of the LHS are unconditionally + // deallocated before assignment (F'2018 10.2.1.3(13)(1)), + // unlike a "top-level" assignment to a variable, where + // deallocation is optional. + // + // Be careful not to destroy/reallocate the LHS, if there is + // overlap between LHS and RHS (it seems that partial overlap + // is not possible, though). + // Invoke Assign() recursively to deal with potential aliasing. if (toDesc->IsAllocatable()) { - if (toDesc->IsAllocated()) { - // Allocatable components of the LHS are unconditionally - // deallocated before assignment (F'2018 10.2.1.3(13)(1)), - // unlike a "top-level" assignment to a variable, where - // deallocation is optional. - // TODO: Consider skipping this step and deferring the - // deallocation to the recursive activation of Assign(), - // which might be able to avoid deallocation/reallocation - // when the existing allocation can be reoccupied. - toDesc->Destroy(false /*already finalized*/); - } if (!fromDesc->IsAllocated()) { + // No aliasing. + // + // If to is not allocated, the Destroy() call is a no-op. + // This is just a shortcut, because the recursive Assign() + // below would initiate the destruction for to. + // No finalization is required. + toDesc->Destroy(); continue; // F'2018 10.2.1.3(13)(2) } - - // F'2018 10.2.1.3(13) (2) - // If from is allocated, allocate to with the same type. - if (nestedFlags & CanBeDefinedAssignment) { - if (AllocateAssignmentLHS( - *toDesc, *fromDesc, terminator, nestedFlags) != StatOk) { - return; - } - } } - Assign(*toDesc, *fromDesc, terminator, nestedFlags); + // Force LHS deallocation with DeallocateLHS flag. + // The actual deallocation may be avoided, if the existing + // location can be reoccupied. + Assign(*toDesc, *fromDesc, terminator, nestedFlags | DeallocateLHS); } break; } @@ -504,6 +509,8 @@ } } if (deferDeallocation) { + // deferDeallocation is used only when LHS is an allocatable. + // The finalization has already been run for it. deferDeallocation->Destroy(); } } diff --git a/flang/test/HLFIR/assign-codegen.fir b/flang/test/HLFIR/assign-codegen.fir --- a/flang/test/HLFIR/assign-codegen.fir +++ b/flang/test/HLFIR/assign-codegen.fir @@ -245,3 +245,25 @@ // CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_2]] : (!fir.ref>>) -> !fir.ref> // CHECK: %[[VAL_11:.*]] = fir.convert %[[VAL_6]] : (!fir.box>) -> !fir.box // CHECK: %[[VAL_13:.*]] = fir.call @_FortranAAssignPolymorphic(%[[VAL_10]], %[[VAL_11]], %{{.*}}, %{{.*}}) : (!fir.ref>, !fir.box, !fir.ref, i32) -> none + +func.func @test_allocatable_component(%arg0: !fir.ref>>}>> {fir.bindc_name = "x", fir.target}, %arg1: !fir.ref>>}>> {fir.bindc_name = "y", fir.target}) { + %4:2 = hlfir.declare %arg0 {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtestEx"} : (!fir.ref>>}>>) -> (!fir.ref>>}>>, !fir.ref>>}>>) + %5:2 = hlfir.declare %arg1 {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtestEy"} : (!fir.ref>>}>>) -> (!fir.ref>>}>>, !fir.ref>>}>>) + hlfir.assign %5#0 to %4#0 : !fir.ref>>}>>, !fir.ref>>}>> + return +} +// CHECK-LABEL: func.func @test_allocatable_component( +// CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>>}>> {fir.bindc_name = "x", fir.target}, +// CHECK-SAME: %[[VAL_1:.*]]: !fir.ref>>}>> {fir.bindc_name = "y", fir.target}) { +// CHECK: %[[VAL_2:.*]] = fir.alloca !fir.box>>}>> +// CHECK: %[[VAL_3:.*]] = fir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtestEx"} : (!fir.ref>>}>>) -> !fir.ref>>}>> +// CHECK: %[[VAL_4:.*]] = fir.declare %[[VAL_1]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtestEy"} : (!fir.ref>>}>>) -> !fir.ref>>}>> +// CHECK: %[[VAL_5:.*]] = fir.embox %[[VAL_3]] : (!fir.ref>>}>>) -> !fir.box>>}>> +// CHECK: %[[VAL_6:.*]] = fir.embox %[[VAL_4]] : (!fir.ref>>}>>) -> !fir.box>>}>> +// CHECK: fir.store %[[VAL_5]] to %[[VAL_2]] : !fir.ref>>}>>> +// CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_2]] : (!fir.ref>>}>>>) -> !fir.ref> +// CHECK: %[[VAL_11:.*]] = fir.convert %[[VAL_6]] : (!fir.box>>}>>) -> !fir.box +// CHECK: %[[VAL_12:.*]] = fir.convert %{{.*}} : (!fir.ref>) -> !fir.ref +// CHECK: %[[VAL_13:.*]] = fir.call @_FortranAAssign(%[[VAL_10]], %[[VAL_11]], %[[VAL_12]], %{{.*}}) : (!fir.ref>, !fir.box, !fir.ref, i32) -> none +// CHECK: return +// CHECK: }