[flang][hlfir] Enable assignments with allocatable components.

[vzakhari]

Summary

The TODO was left there to verify that Assign() runtime handles
overlaps of allocatable components. It did not, and this change-set
fixes it. Note that the same Assign() issue can be reproduced
without HLFIR. In the following example the LHS would be reallocated
before value of RHS (essentially, the same memory) is read:

program main
  type t1
     integer, allocatable :: a(:)
  end type t1
  type(t1) :: x, y
  allocate(x%a(10))
  do i =1,10
     x%a(i) = 2*i
  end do
  x = x
  print *, x%a
  deallocate(x%a)
end program main

The test's output would be incorrect (though, this depends on the memory
reuse by malloc):
0 0 0 0 10 12 14 16 18 20

It is very hard to add a Flang unittest exploiting derived types.

[klausler]

flang/runtime/assign.cpp

333

Did you move this block of code in order to ensure LHS finalization prior to invoking defined assignment? Be advised, finalization applies only to intrinsic assignments (7.5.6.3); a defined assignment subroutine is responsible for calling any final subroutines. Programs with defined assignments basically have to implement everything, including storage allocation and deallocation and finalization, so I get worried when I see other stuff in here that might inappropriately take place "automatically" before a defined assignment procedure gets called.

334

See 10.2.1.3 para 13 for how defined assignment applies during intrinsic assignment with allocatable components with derived types.

[vzakhari]

flang/runtime/assign.cpp

333

Thank you for the references! I tried to follow them with my changes.

I moved the code so that the deallocation and reallocation with AllocateAssignmentLHS kicks in for the component assignment case, i.e. when we call Assign recursively below at line 462. Note that line 462 is currently the only case when we call Assign with CanBeDefinedAssignment flag. Also this call will not set NeedFinalization, so the finalization will not happen. And it will explicitly sey DeallocateLHS to conform to the behavior for allocatable components.

Of course, the main goal of moving this code here was to reuse the MayAlias logic above.

[klausler]

flang/runtime/assign.cpp

333

If *any* deallocation or finalization takes place in a case where defined assignment should be called, it's incorrect. Calling AllocateAssignmentLHS() in a case where defined assignment should be called is incorrect. In short, if control arrives at Assign() for a case that turns out to be defined assignment, Assign() should do *nothing* except call defined assignment. The one exception is the creation and population of a temporary to hold the value of the RHS if it aliases any part of the LHS, since the RHS of a defined assignment must be processed as an expression, not as a variable.

[vzakhari]

flang/runtime/assign.cpp

333

As I understand, by convention with the compiler Assign is not called for the top-level assignments of variables with defined assignments (e.g. CanBeDefinedAssignment flag is not set by any external entry point that calls Assign). The compiler is supposed to call the TBP directly in such cases. Assign may only call TBP for cases where defined assignment is provided for the component of a derived type, e.g.:

Type :: t1
  Integer :: i = 42
Contains
  Procedure :: asgn
  Generic :: Assignment (=) => asgn
End Type
Type :: t2
  Type(t1), Allocatable :: c
End Type

When a variable of type t2 is assigned (with intrinsic assignment) using Assign, 10.2.1.3 para 13 states that the component must be deallocated (if it is allocated) and allocated with the same dynamic type as component of the RHS (if the component is allocated). This is what we have been doing around line 450. This change moves the actions that were done around line 450 into the recursion call, which also makes sure the aliasing is taken into account. I could do the same by "duplicating" the aliasing handling in case typeInfo::Component::Genre::Allocatable below, but I decided to let the recursion handle it.

In other words, with the current agreement between the compiler and runtime, CanBeDefinedAssignment flag can reach here only if an assignment to an allocatable/automatic component is happening as part of an intrinsic assignment of a derived type, in which case the deallocation and AllocateAssignmentLHS is required.

Please let me know if you would prefer the code to be organized differently and how you would like to see it done.

[klausler]

Please address the pre-merge CI build failures before merging.

[vzakhari]

In D152306#4401394, @klausler wrote:

Please address the pre-merge CI build failures before merging.

Thank you for the review! I will fix the source info patterns.

[vzakhari]

Rebased and updated the test before merging.

flang/lib/Optimizer/HLFIR/Transforms/ConvertToFIR.cpp

if (assignOp.isAllocatableAssignment()) {
       mlir::Value to = fir::getBase(builder.createBox(loc, lhsExv));
       // This is not a whole allocatable assignment: the runtime will not
       // reallocate and modify "toMutableBox" even if it is taking it by
       // reference.
       auto toMutableBox = builder.createTemporary(loc, to.getType());
       builder.create<fir::StoreOp>(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);
     return mlir::success();
   }
 };
 
 class CopyInOpConversion : public mlir::OpRewritePattern<hlfir::CopyInOp> {

flang/runtime/assign.cpp

 
 enum AssignFlags {
   NoAssignFlags = 0,
   MaybeReallocate = 1 << 0,
   NeedFinalization = 1 << 1,
   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
 // that must be deallocated?
 static inline bool MustDeallocateLHS(
     Descriptor &to, const Descriptor &from, Terminator &terminator, int flags) {
   // Top-level assignments to allocatable variables (*not* components)
   // may first deallocate existing content if there's about to be a

 // finalizable, this function should be used.
 // When "to" is not a whole allocatable, "from" is an array, and defined
 // assignments are not used, "to" and "from" only need to have the same number
 // of elements, but their shape need not to conform (the assignment is done in
 // element sequence order). This facilitates some internal usages, like when
 // 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()) {
   std::size_t toElementBytes{to.ElementBytes()};
   std::size_t fromElementBytes{from.ElementBytes()};
   auto isSimpleMemmove{[&]() {
     return !toDerived && to.rank() == from.rank() && to.IsContiguous() &&
         from.IsContiguous() && toElementBytes == fromElementBytes;
   }};
   StaticDescriptor<maxRank, true, 10 /*?*/> deferredDeallocStatDesc;
   Descriptor *deferDeallocation{nullptr};
if (mustDeallocateLHS) {
           for (from.GetLowerBounds(fromAt); fromElements-- > 0;
                toAt += fromElementBytes, from.IncrementSubscripts(fromAt)) {
             std::memcpy(toAt, from.Element<char>(fromAt), fromElementBytes);
           }
         }
         Assign(to, newFrom, terminator,
             flags &
                 (NeedFinalization | ComponentCanBeDefinedAssignment |
-                    ExplicitLengthCharacterLHS));
+                    ExplicitLengthCharacterLHS | CanBeDefinedAssignment));
         newFrom.Deallocate();
       }
       return;
     }
   }
   if (to.IsAllocatable()) {
     if (mustDeallocateLHS) {
       if (deferDeallocation) {
if (to.IsAllocatable()) {
     if (!to.IsAllocated()) {
       if (AllocateAssignmentLHS(to, from, terminator, flags) != StatOk) {
         return;
       }
       flags &= ~NeedFinalization;
       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
   // subscript values on each (seemingly) elemental reference into
   // "from".
   SubscriptValue fromAt[maxRank];
   from.GetLowerBounds(fromAt);
   std::size_t toElements{to.Elements()};
for (std::size_t k{0}; k < numComponents; ++k) {
       case typeInfo::Component::Genre::Allocatable:
       case typeInfo::Component::Genre::Automatic:
         for (std::size_t j{0}; j < toElements; ++j,
              to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
           auto *toDesc{reinterpret_cast<Descriptor *>(
               to.Element<char>(toAt) + comp.offset())};
           const auto *fromDesc{reinterpret_cast<const Descriptor *>(
               from.Element<char>(fromAt) + comp.offset())};
-          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*/);
-            }
+          //
+          // 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 (!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;
       }
     }
     // Copy procedure pointer components
     const Descriptor &procPtrDesc{updatedToDerived->procPtr()};
     std::size_t numProcPtrs{procPtrDesc.Elements()};
     for (std::size_t k{0}; k < numProcPtrs; ++k) {
if (isSimpleMemmove()) {
       for (std::size_t n{toElements}; n-- > 0;
            to.IncrementSubscripts(toAt), from.IncrementSubscripts(fromAt)) {
         std::memmove(to.Element<char>(toAt), from.Element<const char>(fromAt),
             toElementBytes);
       }
     }
   }
   if (deferDeallocation) {
+    // deferDeallocation is used only when LHS is an allocatable.
+    // The finalization has already been run for it.
     deferDeallocation->Destroy();
   }
 }
 
 void DoFromSourceAssign(
     Descriptor &alloc, const Descriptor &source, Terminator &terminator) {
   if (alloc.rank() > 0 && source.rank() == 0) {
     // The value of each element of allocate object becomes the value of source.

flang/test/HLFIR/assign-codegen.fir

 // CHECK:           %[[VAL_3:.*]] = fir.no_reassoc %[[VAL_1]] : i1
 // CHECK:           %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (i1) -> !fir.logical<4>
 // CHECK:           %[[VAL_5:.*]] = fir.alloca !fir.logical<4>
 // CHECK:           fir.store %[[VAL_4]] to %[[VAL_5]] : !fir.ref<!fir.logical<4>>
 // CHECK:           %[[VAL_6:.*]] = fir.embox %[[VAL_5]] : (!fir.ref<!fir.logical<4>>) -> !fir.box<!fir.logical<4>>
 // CHECK:           %[[VAL_10:.*]] = fir.convert %[[VAL_2]] : (!fir.ref<!fir.class<!fir.heap<none>>>) -> !fir.ref<!fir.box<none>>
 // CHECK:           %[[VAL_11:.*]] = fir.convert %[[VAL_6]] : (!fir.box<!fir.logical<4>>) -> !fir.box<none>
 // CHECK:           %[[VAL_13:.*]] = fir.call @_FortranAAssignPolymorphic(%[[VAL_10]], %[[VAL_11]], %{{.*}}, %{{.*}}) : (!fir.ref<!fir.box<none>>, !fir.box<none>, !fir.ref<i8>, i32) -> none
+
+func.func @test_allocatable_component(%arg0: !fir.ref<!fir.type<_QFtestTt1{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>> {fir.bindc_name = "x", fir.target}, %arg1: !fir.ref<!fir.type<_QFtestTt1{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>> {fir.bindc_name = "y", fir.target}) {
+  %4:2 = hlfir.declare %arg0 {fortran_attrs = #fir.var_attrs<target>, uniq_name = "_QFtestEx"} : (!fir.ref<!fir.type<_QFtestTt1{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>) -> (!fir.ref<!fir.type<_QFtestTt1{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>, !fir.ref<!fir.type<_QFtestTt1{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>)
+  %5:2 = hlfir.declare %arg1 {fortran_attrs = #fir.var_attrs<target>, uniq_name = "_QFtestEy"} : (!fir.ref<!fir.type<_QFtestTt1{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>) -> (!fir.ref<!fir.type<_QFtestTt1{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>, !fir.ref<!fir.type<_QFtestTt1{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>)
+  hlfir.assign %5#0 to %4#0 : !fir.ref<!fir.type<_QFtestTt1{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>, !fir.ref<!fir.type<_QFtestTt1{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>
+  return
+}
+// CHECK-LABEL:   func.func @test_allocatable_component(
+// CHECK-SAME:                                          %[[VAL_0:.*]]: !fir.ref<!fir.type<_QFtestTt1{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>> {fir.bindc_name = "x", fir.target},
+// CHECK-SAME:                                          %[[VAL_1:.*]]: !fir.ref<!fir.type<_QFtestTt1{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>> {fir.bindc_name = "y", fir.target}) {
+// CHECK:           %[[VAL_2:.*]] = fir.alloca !fir.box<!fir.type<_QFtestTt1{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>
+// CHECK:           %[[VAL_3:.*]] = fir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<target>, uniq_name = "_QFtestEx"} : (!fir.ref<!fir.type<_QFtestTt1{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>) -> !fir.ref<!fir.type<_QFtestTt1{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>
+// CHECK:           %[[VAL_4:.*]] = fir.declare %[[VAL_1]] {fortran_attrs = #fir.var_attrs<target>, uniq_name = "_QFtestEy"} : (!fir.ref<!fir.type<_QFtestTt1{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>) -> !fir.ref<!fir.type<_QFtestTt1{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>
+// CHECK:           %[[VAL_5:.*]] = fir.embox %[[VAL_3]] : (!fir.ref<!fir.type<_QFtestTt1{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>) -> !fir.box<!fir.type<_QFtestTt1{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>
+// CHECK:           %[[VAL_6:.*]] = fir.embox %[[VAL_4]] : (!fir.ref<!fir.type<_QFtestTt1{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>) -> !fir.box<!fir.type<_QFtestTt1{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>
+// CHECK:           fir.store %[[VAL_5]] to %[[VAL_2]] : !fir.ref<!fir.box<!fir.type<_QFtestTt1{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>>
+// CHECK:           %[[VAL_10:.*]] = fir.convert %[[VAL_2]] : (!fir.ref<!fir.box<!fir.type<_QFtestTt1{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>>) -> !fir.ref<!fir.box<none>>
+// CHECK:           %[[VAL_11:.*]] = fir.convert %[[VAL_6]] : (!fir.box<!fir.type<_QFtestTt1{a:!fir.box<!fir.heap<!fir.array<?xi32>>>}>>) -> !fir.box<none>
+// CHECK:           %[[VAL_12:.*]] = fir.convert %{{.*}} : (!fir.ref<!fir.char<1,{{.*}}>>) -> !fir.ref<i8>
+// CHECK:           %[[VAL_13:.*]] = fir.call @_FortranAAssign(%[[VAL_10]], %[[VAL_11]], %[[VAL_12]], %{{.*}}) : (!fir.ref<!fir.box<none>>, !fir.box<none>, !fir.ref<i8>, i32) -> none
+// CHECK:           return
+// CHECK:         }