[flang] Finalize allocatable components in expression results

An expression result is a "data entity" (F'2023 3.41), and thus
can be "finalizable" (3.71); however, they are not finalized
in general because there is no item in the list of events that trigger
finalization (7.5.6.3p2) that applies, apart from two relevant
exceptions.  One of them we handle correctly (allocatable function
results) we handle correctly, the other we do not.

The second exception is the case of allocated allocatables which
may appear as subobjects in an expression result.  They are
automatically deallocated (9.7.3.2p9), and deallocation is on that
list of finalization-triggering events (7.5.6.3p2).
So this patch makes sure to finalize any allocatable finalizable
subobject, unless the destruction is part of the left-hand side of
an intrinsic assignment -- in which case it will have already been
finalized (7.5.6.3p1) anyway.

Note: the "stop 171" case in the test
  llvm-test-suite/Fortran/gfortran/regression/finalize_38.f90
will now fail, and a companion patch will disable that test when
this patch is merged.

Author: klausler

flang-rt/include/flang-rt/runtime/work-queue.h

@@ -298,15 +298,18 @@ class DestroyTicket : public ImmediateTicketRunner<DestroyTicket>,
                       private ComponentsOverElements {
 public:
   RT_API_ATTRS DestroyTicket(const Descriptor &instance,
-      const typeInfo::DerivedType &derived, bool finalize)
+      const typeInfo::DerivedType &derived, bool finalize,
+      bool isNestedFinalizationPossible)
       : ImmediateTicketRunner<DestroyTicket>{*this},
         ComponentsOverElements{instance, derived}, finalize_{finalize},
+        isNestedFinalizationPossible_{isNestedFinalizationPossible},
         fixedStride_{instance.FixedStride()} {}
   RT_API_ATTRS int Begin(WorkQueue &);
   RT_API_ATTRS int Continue(WorkQueue &);
 
 private:
   bool finalize_{false};
+  bool isNestedFinalizationPossible_{false};
   common::optional<SubscriptValue> fixedStride_;
 };
 
@@ -479,11 +482,15 @@ class WorkQueue {
     }
   }
   RT_API_ATTRS int BeginDestroy(const Descriptor &descriptor,
-      const typeInfo::DerivedType &derived, bool finalize) {
+      const typeInfo::DerivedType &derived, bool finalize,
+      bool isNestedFinalizationPossible) {
     if (runTicketsImmediately_) {
-      return DestroyTicket{descriptor, derived, finalize}.Run(*this);
+      return DestroyTicket{
+          descriptor, derived, finalize, isNestedFinalizationPossible}
+          .Run(*this);
     } else {
-      StartTicket().u.emplace<DestroyTicket>(descriptor, derived, finalize);
+      StartTicket().u.emplace<DestroyTicket>(
+          descriptor, derived, finalize, isNestedFinalizationPossible);
       return StatContinue;
     }
   }

flang-rt/lib/runtime/assign.cpp

@@ -373,7 +373,8 @@ RT_API_ATTRS int AssignTicket::Begin(WorkQueue &workQueue) {
       // is executed, any noncoarray allocated allocatable subobject of the
       // variable is deallocated before the assignment takes place."
       if (int status{
-              workQueue.BeginDestroy(to_, *toDerived_, /*finalize=*/false)};
+              workQueue.BeginDestroy(to_, *toDerived_, /*finalize=*/false,
+                  /*isNestedFinalizationPossible=*/false)};
           status != StatOk && status != StatContinue) {
         return status;
       }
@@ -683,8 +684,9 @@ RT_API_ATTRS int DerivedAssignTicket<IS_COMPONENTWISE>::Continue(
         if (toDesc->IsAllocated()) {
           if (this->phase_ == 0) {
             if (componentDerived && !componentDerived->noDestructionNeeded()) {
-              if (int status{workQueue.BeginDestroy(
-                      *toDesc, *componentDerived, /*finalize=*/false)};
+              if (int status{workQueue.BeginDestroy(*toDesc, *componentDerived,
+                      /*finalize=*/false,
+                      /*isNestedFinalizationPossible=*/false)};
                   status != StatOk) {
                 this->phase_++;
                 return status;

flang-rt/lib/runtime/derived-api.cpp

@@ -46,7 +46,7 @@ void RTDEF(Destroy)(const Descriptor &descriptor) {
       if (!derived->noDestructionNeeded()) {
         // TODO: Pass source file & line information to the API
         // so that a good Terminator can be passed
-        Destroy(descriptor, true, *derived, nullptr);
+        Destroy(descriptor, /*finalize=*/true, *derived, nullptr);
       }
     }
   }
@@ -144,6 +144,10 @@ bool RTDEF(ExtendsTypeOf)(const Descriptor &a, const Descriptor &mold) {
   }
 }
 
+// The object will be destroyed without finalization at the top level,
+// but allocated allocatable subobjects must be deallocated, and
+// deallocation is a finalization-triggering event, so they will
+// be finalized regardless.
 void RTDEF(DestroyWithoutFinalization)(const Descriptor &descriptor) {
   if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {
     if (const auto *derived{addendum->derivedType()}) {

flang-rt/lib/runtime/derived.cpp

@@ -396,24 +396,28 @@ RT_API_ATTRS int FinalizeTicket::Continue(WorkQueue &workQueue) {
 
 // The order of finalization follows Fortran 2018 7.5.6.2, with
 // elementwise finalization of non-parent components taking place
-// before parent component finalization, and with all finalization
-// preceding any deallocation.
+// before parent component finalization, and with all "top level"
+// finalization preceding any deallocation.
 RT_API_ATTRS void Destroy(const Descriptor &descriptor, bool finalize,
     const typeInfo::DerivedType &derived, Terminator *terminator) {
   if (descriptor.IsAllocated() && !derived.noDestructionNeeded()) {
     Terminator stubTerminator{"Destroy() in Fortran runtime", 0};
     WorkQueue workQueue{terminator ? *terminator : stubTerminator};
-    if (workQueue.BeginDestroy(descriptor, derived, finalize) == StatContinue) {
+    if (workQueue.BeginDestroy(descriptor, derived, finalize,
+            /*isNestedFinalizationPossible=*/!finalize) == StatContinue) {
       workQueue.Run();
     }
   }
 }
 
 RT_API_ATTRS int DestroyTicket::Begin(WorkQueue &workQueue) {
-  if (finalize_ && !derived_.noFinalizationNeeded()) {
-    if (int status{workQueue.BeginFinalize(instance_, derived_)};
-        status != StatOk && status != StatContinue) {
-      return status;
+  if (finalize_) {
+    isNestedFinalizationPossible_ = false;
+    if (!derived_.noFinalizationNeeded()) {
+      if (int status{workQueue.BeginFinalize(instance_, derived_)};
+          status != StatOk && status != StatContinue) {
+        return status;
+      }
     }
   }
   return StatContinue;
@@ -440,8 +444,13 @@ RT_API_ATTRS int DestroyTicket::Continue(WorkQueue &workQueue) {
         if (d.IsAllocated()) {
           if (componentDerived && !componentDerived->noDestructionNeeded() &&
               phase_ == 0) {
-            if (int status{workQueue.BeginDestroy(
-                    d, *componentDerived, /*finalize=*/false)};
+            // Per F'2023 7.5.6.3p2, deallocations are finalization-triggering
+            // events -- so if an allocatable component was not finalized
+            // before, and we're not in the left-hand side of an intrinsic
+            // assignment, it must be finalized now.
+            if (int status{workQueue.BeginDestroy(d, *componentDerived,
+                    /*finalize=*/!finalize_ && isNestedFinalizationPossible_,
+                    isNestedFinalizationPossible_)};
                 status != StatOk) {
               ++phase_;
               return status;
@@ -465,8 +474,8 @@ RT_API_ATTRS int DestroyTicket::Continue(WorkQueue &workQueue) {
             ++j, p += *fixedStride_) {
           compDesc.set_base_addr(p);
           ++elementAt_;
-          if (int status{workQueue.BeginDestroy(
-                  compDesc, compType, /*finalize=*/false)};
+          if (int status{workQueue.BeginDestroy(compDesc, compType,
+                  /*finalize=*/false, isNestedFinalizationPossible_)};
               status != StatOk) {
             return status;
           }
@@ -481,8 +490,8 @@ RT_API_ATTRS int DestroyTicket::Continue(WorkQueue &workQueue) {
             instance_.ElementComponent<char>(subscripts_, component_->offset()),
             component_->rank(), extents);
         Advance();
-        if (int status{
-                workQueue.BeginDestroy(compDesc, compType, /*finalize=*/false)};
+        if (int status{workQueue.BeginDestroy(compDesc, compType,
+                /*finalize=*/false, isNestedFinalizationPossible_)};
             status != StatOk) {
           return status;
         }

flang/docs/Extensions.md

@@ -817,20 +817,12 @@ end
   `INDEX` include an optional `BACK=` argument, but it doesn't actually
   work.
 
-* Allocatable components of array and structure constructors are deallocated
-  after use without calling final subroutines.
-  The standard does not specify when and how deallocation of array and structure
-  constructors allocatable components should happen. All compilers free the
-  memory after use, but the behavior when the allocatable component is a derived
-  type with finalization differ, especially when dealing with nested array and
-  structure constructors expressions. Some compilers call final routine for the
-  allocatable components of each constructor sub-expressions, some call it only
-  for the allocatable component of the top level constructor, and some only
-  deallocate the memory. Deallocating only the memory offers the most
-  flexibility when lowering such expressions, and it is not clear finalization
-  is desirable in such context (Fortran interop 1.6.2 in F2018 standards require
-  array and structure constructors not to be finalized, so it also makes sense
-  not to finalize their allocatable components when releasing their storage).
+* Allocatable components nested in expression results are finalized before being
+  deallocated.  F'2023 identifies expression results as "data entities", and
+  the deallocation of non-coarray allocatables as being an event that triggers
+  finalization.  Compilers differ widely in their finalization behavior in
+  expression results, especially with structure constructors, but at least two
+  others match this interpretation and it seems clear enough in the standard.
 
 * F'2023 19.4 paragraph 5: "If integer-type-spec appears in data-implied-do or
   ac-implied-do-control it has the specified type and type parameters; otherwise