[flang] Do not move finalized function results in lowering (#80683)

Fortran requires finalizing function results when the result type have
final procedures.

Lowering was unconditionally "moving" function results into values
"hlfir.expr". This is not correct when the results are finalized because
it means the function result storage will be used after the hlfir.expr.

Only move function results that are not finalized.

Author: jeanPerier

flang/include/flang/Lower/ConvertCall.h

@@ -30,7 +30,9 @@ namespace Fortran::lower {
 /// link to internal procedures.
 /// \p isElemental must be set to true if elemental call is being produced.
 /// It is only used for HLFIR.
-fir::ExtendedValue genCallOpAndResult(
+/// The returned boolean indicates if finalization has been emitted in
+/// \p stmtCtx for the result.
+std::pair<fir::ExtendedValue, bool> genCallOpAndResult(
     mlir::Location loc, Fortran::lower::AbstractConverter &converter,
     Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx,
     Fortran::lower::CallerInterface &caller, mlir::FunctionType callSiteType,

flang/include/flang/Optimizer/Builder/MutableBox.h

@@ -150,7 +150,8 @@ void syncMutableBoxFromIRBox(fir::FirOpBuilder &builder, mlir::Location loc,
 fir::ExtendedValue genMutableBoxRead(fir::FirOpBuilder &builder,
                                      mlir::Location loc,
                                      const fir::MutableBoxValue &box,
-                                     bool mayBePolymorphic = true);
+                                     bool mayBePolymorphic = true,
+                                     bool preserveLowerBounds = true);
 
 /// Returns the fir.ref<fir.box<T>> of a MutableBoxValue filled with the current
 /// association / allocation properties. If the fir.ref<fir.box> already exists

flang/lib/Lower/ConvertCall.cpp

@@ -42,6 +42,8 @@ static llvm::cl::opt<bool> useHlfirIntrinsicOps(
     llvm::cl::desc("Lower via HLFIR transformational intrinsic operations such "
                    "as hlfir.sum"));
 
+static constexpr char tempResultName[] = ".tmp.func_result";
+
 /// Helper to package a Value and its properties into an ExtendedValue.
 static fir::ExtendedValue toExtendedValue(mlir::Location loc, mlir::Value base,
                                           llvm::ArrayRef<mlir::Value> extents,
@@ -147,7 +149,7 @@ static bool mustCastFuncOpToCopeWithImplicitInterfaceMismatch(
   return false;
 }
 
-fir::ExtendedValue Fortran::lower::genCallOpAndResult(
+std::pair<fir::ExtendedValue, bool> Fortran::lower::genCallOpAndResult(
     mlir::Location loc, Fortran::lower::AbstractConverter &converter,
     Fortran::lower::SymMap &symMap, Fortran::lower::StatementContext &stmtCtx,
     Fortran::lower::CallerInterface &caller, mlir::FunctionType callSiteType,
@@ -478,6 +480,7 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
         [](const auto &) {});
 
     // 7.5.6.3 point 5. Derived-type finalization for nonpointer function.
+    bool resultIsFinalized = false;
     // Check if the derived-type is finalizable if it is a monomorphic
     // derived-type.
     // For polymorphic and unlimited polymorphic enities call the runtime
@@ -499,6 +502,7 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
           fir::runtime::genDerivedTypeDestroy(*bldr, loc,
                                               fir::getBase(*allocatedResult));
         });
+        resultIsFinalized = true;
       } else {
         const Fortran::semantics::DerivedTypeSpec &typeSpec =
             retTy->GetDerivedTypeSpec();
@@ -513,14 +517,17 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
             mlir::Value box = bldr->createBox(loc, *allocatedResult);
             fir::runtime::genDerivedTypeDestroy(*bldr, loc, box);
           });
+          resultIsFinalized = true;
         }
       }
     }
-    return *allocatedResult;
+    return {*allocatedResult, resultIsFinalized};
   }
 
+  // subroutine call
   if (!resultType)
-    return mlir::Value{}; // subroutine call
+    return {fir::ExtendedValue{mlir::Value{}}, /*resultIsFinalized=*/false};
+
   // For now, Fortran return values are implemented with a single MLIR
   // function return value.
   assert(callNumResults == 1 && "Expected exactly one result in FUNCTION call");
@@ -533,10 +540,10 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
         funcType.getResults()[0].dyn_cast<fir::CharacterType>();
     mlir::Value len = builder.createIntegerConstant(
         loc, builder.getCharacterLengthType(), charTy.getLen());
-    return fir::CharBoxValue{callResult, len};
+    return {fir::CharBoxValue{callResult, len}, /*resultIsFinalized=*/false};
   }
 
-  return callResult;
+  return {callResult, /*resultIsFinalized=*/false};
 }
 
 static hlfir::EntityWithAttributes genStmtFunctionRef(
@@ -1389,7 +1396,7 @@ genUserCall(Fortran::lower::PreparedActualArguments &loweredActuals,
   // Prepare lowered arguments according to the interface
   // and map the lowered values to the dummy
   // arguments.
-  fir::ExtendedValue result = Fortran::lower::genCallOpAndResult(
+  auto [result, resultIsFinalized] = Fortran::lower::genCallOpAndResult(
       loc, callContext.converter, callContext.symMap, callContext.stmtCtx,
       caller, callSiteType, callContext.resultType,
       callContext.isElementalProcWithArrayArgs());
@@ -1404,24 +1411,43 @@ genUserCall(Fortran::lower::PreparedActualArguments &loweredActuals,
   if (!fir::getBase(result))
     return std::nullopt; // subroutine call.
 
-  hlfir::Entity resultEntity =
-      extendedValueToHlfirEntity(loc, builder, result, ".tmp.func_result");
+  if (fir::isPointerType(fir::getBase(result).getType()))
+    return extendedValueToHlfirEntity(loc, builder, result, tempResultName);
 
-  if (!fir::isPointerType(fir::getBase(result).getType())) {
+  if (!resultIsFinalized) {
+    hlfir::Entity resultEntity =
+        extendedValueToHlfirEntity(loc, builder, result, tempResultName);
     resultEntity = loadTrivialScalar(loc, builder, resultEntity);
-
     if (resultEntity.isVariable()) {
-      // Function result must not be freed, since it is allocated on the stack.
-      // Note that in non-elemental case, genCallOpAndResult()
-      // is responsible for establishing the clean-up that destroys
-      // the derived type result or deallocates its components
-      // without finalization.
+      // If the result has no finalization, it can be moved into an expression.
+      // In such case, the expression should not be freed after its use since
+      // the result is stack allocated or deallocation (for allocatable results)
+      // was already inserted in genCallOpAndResult.
       auto asExpr = builder.create<hlfir::AsExprOp>(
           loc, resultEntity, /*mustFree=*/builder.createBool(loc, false));
-      resultEntity = hlfir::EntityWithAttributes{asExpr.getResult()};
+      return hlfir::EntityWithAttributes{asExpr.getResult()};
     }
+    return hlfir::EntityWithAttributes{resultEntity};
   }
-  return hlfir::EntityWithAttributes{resultEntity};
+  // If the result has finalization, it cannot be moved because use of its
+  // value have been created in the statement context and may be emitted
+  // after the hlfir.expr destroy, so the result is kept as a variable in
+  // HLFIR. This may lead to copies when passing the result to an argument
+  // with VALUE, and this do not convey the fact that the result will not
+  // change, but is correct, and using hlfir.expr without the move would
+  // trigger a copy that may be avoided.
+
+  // Load allocatable results before emitting the hlfir.declare and drop its
+  // lower bounds: this is not a variable From the Fortran point of view, so
+  // the lower bounds are ones when inquired on the caller side.
+  const auto *allocatable = result.getBoxOf<fir::MutableBoxValue>();
+  fir::ExtendedValue loadedResult =
+      allocatable
+          ? fir::factory::genMutableBoxRead(builder, loc, *allocatable,
+                                            /*mayBePolymorphic=*/true,
+                                            /*preserveLowerBounds=*/false)
+          : result;
+  return extendedValueToHlfirEntity(loc, builder, loadedResult, tempResultName);
 }
 
 /// Create an optional dummy argument value from an entity that may be

flang/lib/Lower/ConvertExpr.cpp

@@ -2846,8 +2846,10 @@ class ScalarExprLowering {
       }
     }
 
-    ExtValue result = Fortran::lower::genCallOpAndResult(
-        loc, converter, symMap, stmtCtx, caller, callSiteType, resultType);
+    ExtValue result =
+        Fortran::lower::genCallOpAndResult(loc, converter, symMap, stmtCtx,
+                                           caller, callSiteType, resultType)
+            .first;
 
     // Sync pointers and allocatables that may have been modified during the
     // call.
@@ -4866,8 +4868,10 @@ class ArrayExprLowering {
             [&](const auto &) { return fir::getBase(exv); });
         caller.placeInput(argIface, arg);
       }
-      return Fortran::lower::genCallOpAndResult(
-          loc, converter, symMap, getElementCtx(), caller, callSiteType, retTy);
+      return Fortran::lower::genCallOpAndResult(loc, converter, symMap,
+                                                getElementCtx(), caller,
+                                                callSiteType, retTy)
+          .first;
     };
   }
 

flang/lib/Optimizer/Builder/MutableBox.cpp

@@ -406,22 +406,26 @@ static bool readToBoxValue(const fir::MutableBoxValue &box,
 fir::ExtendedValue
 fir::factory::genMutableBoxRead(fir::FirOpBuilder &builder, mlir::Location loc,
                                 const fir::MutableBoxValue &box,
-                                bool mayBePolymorphic) {
+                                bool mayBePolymorphic,
+                                bool preserveLowerBounds) {
   if (box.hasAssumedRank())
     TODO(loc, "assumed rank allocatables or pointers");
   llvm::SmallVector<mlir::Value> lbounds;
   llvm::SmallVector<mlir::Value> extents;
   llvm::SmallVector<mlir::Value> lengths;
   if (readToBoxValue(box, mayBePolymorphic)) {
     auto reader = MutablePropertyReader(builder, loc, box);
-    reader.getLowerBounds(lbounds);
+    if (preserveLowerBounds)
+      reader.getLowerBounds(lbounds);
     return fir::BoxValue{reader.getIrBox(), lbounds,
                          box.nonDeferredLenParams()};
   }
   // Contiguous intrinsic type entity: all the data can be extracted from the
   // fir.box.
   auto addr =
       MutablePropertyReader(builder, loc, box).read(lbounds, extents, lengths);
+  if (!preserveLowerBounds)
+    lbounds.clear();
   auto rank = box.rank();
   if (box.isCharacter()) {
     auto len = lengths.empty() ? mlir::Value{} : lengths[0];

flang/test/Lower/HLFIR/function-return-as-expr.f90

@@ -66,11 +66,26 @@ function inner()
   end function inner
 end subroutine test4
 ! CHECK-LABEL:   func.func @_QPtest4() {
-! CHECK:           %[[VAL_6:.*]]:2 = hlfir.declare %{{.*}} {uniq_name = ".tmp.func_result"} : (!fir.ref<!fir.class<!fir.heap<none>>>) -> (!fir.ref<!fir.class<!fir.heap<none>>>, !fir.ref<!fir.class<!fir.heap<none>>>)
-! CHECK:           %[[VAL_7:.*]] = fir.load %[[VAL_6]]#0 : !fir.ref<!fir.class<!fir.heap<none>>>
-! CHECK:           %[[VAL_8:.*]] = arith.constant false
-! CHECK:           %[[VAL_9:.*]] = hlfir.as_expr %[[VAL_7]] move %[[VAL_8]] : (!fir.class<!fir.heap<none>>, i1) -> !hlfir.expr<none?>
-! CHECK:           hlfir.assign %[[VAL_9]] to %{{.*}}#0 realloc : !hlfir.expr<none?>, !fir.ref<!fir.class<!fir.heap<none>>>
+! CHECK:           %[[VAL_6:.*]] = fir.load %[[VAL_0:.*]] : !fir.ref<!fir.class<!fir.heap<none>>>
+! CHECK:           %[[VAL_7:.*]]:2 = hlfir.declare %[[VAL_6]] {uniq_name = ".tmp.func_result"} : (!fir.class<!fir.heap<none>>) -> (!fir.class<!fir.heap<none>>, !fir.class<!fir.heap<none>>)
+! CHECK:           hlfir.assign %[[VAL_7]]#0 to %{{.*}}#0 realloc : !fir.class<!fir.heap<none>>, !fir.ref<!fir.class<!fir.heap<none>>>
+! CHECK:           %[[VAL_10:.*]] = fir.convert %[[VAL_0]] : (!fir.ref<!fir.class<!fir.heap<none>>>) -> !fir.box<none>
+! CHECK:           fir.call @_FortranADestroy(%[[VAL_10]]) fastmath<contract> : (!fir.box<none>) -> none
+
+subroutine test4b
+  class(*), allocatable :: p(:, :)
+  p = inner()
+contains
+  function inner()
+    class(*), allocatable :: inner(:, :)
+  end function inner
+end subroutine test4b
+! CHECK-LABEL:   func.func @_QPtest4b() {
+! CHECK:           %[[VAL_6:.*]] = fir.load %[[VAL_0:.*]] : !fir.ref<!fir.class<!fir.heap<!fir.array<?x?xnone>>>>
+! CHECK:           %[[VAL_7:.*]]:2 = hlfir.declare %[[VAL_6]] {uniq_name = ".tmp.func_result"} : (!fir.class<!fir.heap<!fir.array<?x?xnone>>>) -> (!fir.class<!fir.heap<!fir.array<?x?xnone>>>, !fir.class<!fir.heap<!fir.array<?x?xnone>>>)
+! CHECK:           hlfir.assign %[[VAL_7]]#0 to %{{.*}}#0 realloc : !fir.class<!fir.heap<!fir.array<?x?xnone>>>, !fir.ref<!fir.class<!fir.heap<!fir.array<?x?xnone>>>>
+! CHECK:           %[[VAL_10:.*]] = fir.convert %[[VAL_0]] : (!fir.ref<!fir.class<!fir.heap<!fir.array<?x?xnone>>>>) -> !fir.box<none>
+! CHECK:           fir.call @_FortranADestroy(%[[VAL_10]]) fastmath<contract> : (!fir.box<none>) -> none
 
 subroutine test5
   use types