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

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.

Reviewed By: klausler

Differential Revision: https://reviews.llvm.org/D152306

diff --git a/flang/lib/Optimizer/HLFIR/Transforms/ConvertToFIR.cpp b/flang/lib/Optimizer/HLFIR/Transforms/ConvertToFIR.cpp
index 22ad5371543c9867f6cedb3c11210877b8ff2f36..4cb5cd6fdbf4c328495cc996c7d21b824db049d6 100644 (file)
--- a/flang/lib/Optimizer/HLFIR/Transforms/ConvertToFIR.cpp
+++ b/flang/lib/Optimizer/HLFIR/Transforms/ConvertToFIR.cpp
@@ -140,14 +140,10 @@ public:
       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);

diff --git a/flang/runtime/assign.cpp b/flang/runtime/assign.cpp
index 49e86c20b17cc8ed1150b2f3021250983004b96a..80ad97c4e6da063f942670e47dbaa54ed2e313a8 100644 (file)
--- a/flang/runtime/assign.cpp
+++ b/flang/runtime/assign.cpp
@@ -23,7 +23,8 @@ enum AssignFlags {
   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 @@ static void BlankPadCharacterAssignment(Descriptor &to, const Descriptor &from,
 // 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 @@ static void Assign(
         Assign(to, newFrom, terminator,
             flags &
                 (NeedFinalization | ComponentCanBeDefinedAssignment |
-                    ExplicitLengthCharacterLHS));
+                    ExplicitLengthCharacterLHS | CanBeDefinedAssignment));
         newFrom.Deallocate();
       }
       return;
@@ -345,6 +330,27 @@ static void Assign(
       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 @@ static void Assign(
               to.Element<char>(toAt) + comp.offset())};
           const auto *fromDesc{reinterpret_cast<const Descriptor *>(
               from.Element<char>(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 @@ static void Assign(
     }
   }
   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
index 401d55bb53940ed6e4681d774ce282f9ed021f14..7d3b4d54b04cf9659c37aa102dba087d6dbd46ab 100644 (file)
--- a/flang/test/HLFIR/assign-codegen.fir
+++ b/flang/test/HLFIR/assign-codegen.fir
@@ -245,3 +245,25 @@ func.func @assign_i1_to_polymorphic(%arg0: !fir.ref<!fir.class<!fir.heap<none>>>
 // 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:         }