[flang] Deallocate intent(out) allocatables

From Fortran 2018 standard 9.7.3.2 point 6:
When a procedure is invoked, any allocated allocatable object that is an actual
argument corresponding to an INTENT (OUT) allocatable dummy argument is
deallocated; any allocated allocatable object that is a subobject of an actual
argument corresponding to an INTENT (OUT) dummy argument is deallocated.

Deallocation is done on the callee side. For BIND(C) procedure, the deallocation
is also done on the caller side.

Reviewed By: jeanPerier

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

diff --git a/flang/include/flang/Lower/Allocatable.h b/flang/include/flang/Lower/Allocatable.h
index a54daad..7776f04 100644 (file)
--- a/flang/include/flang/Lower/Allocatable.h
+++ b/flang/include/flang/Lower/Allocatable.h
@@ -48,6 +48,9 @@ void genAllocateStmt(AbstractConverter &converter,
 void genDeallocateStmt(AbstractConverter &converter,
                        const parser::DeallocateStmt &stmt, mlir::Location loc);
 
+void genDeallocateBox(AbstractConverter &converter,
+                      const fir::MutableBoxValue &box, mlir::Location loc);
+
 /// Create a MutableBoxValue for an allocatable or pointer entity.
 /// If the variables is a local variable that is not a dummy, it will be
 /// initialized to unallocated/diassociated status.

diff --git a/flang/include/flang/Lower/CallInterface.h b/flang/include/flang/Lower/CallInterface.h
index 06724e0..0a8bad0 100644 (file)
--- a/flang/include/flang/Lower/CallInterface.h
+++ b/flang/include/flang/Lower/CallInterface.h
@@ -159,6 +159,8 @@ public:
     bool mayBeModifiedByCall() const;
     /// Can the argument be read by the callee ?
     bool mayBeReadByCall() const;
+    /// Is the argument INTENT(OUT)
+    bool isIntentOut() const;
     /// How entity is passed by.
     PassEntityBy passBy;
     /// What is the entity (SymbolRef for callee/ActualArgument* for caller)

diff --git a/flang/lib/Lower/Allocatable.cpp b/flang/lib/Lower/Allocatable.cpp
index 08a9444..8d0db01 100644 (file)
--- a/flang/lib/Lower/Allocatable.cpp
+++ b/flang/lib/Lower/Allocatable.cpp
@@ -523,6 +523,17 @@ static void genDeallocate(fir::FirOpBuilder &builder, mlir::Location loc,
   errorManager.assignStat(builder, loc, stat);
 }
 
+void Fortran::lower::genDeallocateBox(
+    Fortran::lower::AbstractConverter &converter,
+    const fir::MutableBoxValue &box, mlir::Location loc) {
+  const Fortran::lower::SomeExpr *statExpr = nullptr;
+  const Fortran::lower::SomeExpr *errMsgExpr = nullptr;
+  ErrorManager errorManager;
+  errorManager.init(converter, loc, statExpr, errMsgExpr);
+  fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+  genDeallocate(builder, loc, box, errorManager);
+}
+
 void Fortran::lower::genDeallocateStmt(
     Fortran::lower::AbstractConverter &converter,
     const Fortran::parser::DeallocateStmt &stmt, mlir::Location loc) {

diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp
index 5928149..5b77d02 100644 (file)
--- a/flang/lib/Lower/CallInterface.cpp
+++ b/flang/lib/Lower/CallInterface.cpp
@@ -1048,6 +1048,12 @@ bool Fortran::lower::CallInterface<T>::PassedEntity::mayBeReadByCall() const {
     return true;
   return characteristics->GetIntent() != Fortran::common::Intent::Out;
 }
+template <typename T>
+bool Fortran::lower::CallInterface<T>::PassedEntity::isIntentOut() const {
+  if (!characteristics)
+    return true;
+  return characteristics->GetIntent() == Fortran::common::Intent::Out;
+}
 
 template <typename T>
 void Fortran::lower::CallInterface<T>::determineInterface(

diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp
index 209ebf1..91f2327 100644 (file)
--- a/flang/lib/Lower/ConvertExpr.cpp
+++ b/flang/lib/Lower/ConvertExpr.cpp
@@ -3239,6 +3239,9 @@ public:
         caller.placeInput(arg, irBox);
         if (arg.mayBeModifiedByCall())
           mutableModifiedByCall.emplace_back(std::move(mutableBox));
+        if (fir::isAllocatableType(argTy) && arg.isIntentOut() &&
+            Fortran::semantics::IsBindCProcedure(*procRef.proc().GetSymbol()))
+          Fortran::lower::genDeallocateBox(converter, mutableBox, loc);
         continue;
       }
       if (arg.passBy == PassBy::BaseAddress || arg.passBy == PassBy::BoxChar ||

diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp
index b99952d..a47b8f7 100644 (file)
--- a/flang/lib/Lower/ConvertVariable.cpp
+++ b/flang/lib/Lower/ConvertVariable.cpp
@@ -603,6 +603,38 @@ defaultInitializeAtRuntime(Fortran::lower::AbstractConverter &converter,
   }
 }
 
+// Fortran 2018 - 9.7.3.2 point 6
+// When a procedure is invoked, any allocated allocatable object that is an
+// actual argument corresponding to an INTENT(OUT) allocatable dummy argument
+// is deallocated; any allocated allocatable object that is a subobject of an
+// actual argument corresponding to an INTENT(OUT) dummy argument is
+// deallocated.
+static void deallocateIntentOut(Fortran::lower::AbstractConverter &converter,
+                                const Fortran::lower::pft::Variable &var,
+                                Fortran::lower::SymMap &symMap) {
+  const Fortran::semantics::Symbol &sym = var.getSymbol();
+  if (Fortran::semantics::IsDummy(sym) &&
+      Fortran::semantics::IsIntentOut(sym) &&
+      Fortran::semantics::IsAllocatable(sym)) {
+    if (auto symbox = symMap.lookupSymbol(sym)) {
+      fir::ExtendedValue extVal = symbox.toExtendedValue();
+      if (auto mutBox = extVal.getBoxOf<fir::MutableBoxValue>()) {
+        mlir::Location loc = converter.getCurrentLocation();
+        if (Fortran::semantics::IsOptional(sym)) {
+          fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+          auto isPresent = builder.create<fir::IsPresentOp>(
+              loc, builder.getI1Type(), fir::getBase(extVal));
+          builder.genIfThen(loc, isPresent)
+              .genThen([&]() { genDeallocateBox(converter, *mutBox, loc); })
+              .end();
+        } else {
+          genDeallocateBox(converter, *mutBox, loc);
+        }
+      }
+    }
+  }
+}
+
 /// Instantiate a local variable. Precondition: Each variable will be visited
 /// such that if its properties depend on other variables, the variables upon
 /// which its properties depend will already have been visited.
@@ -612,6 +644,7 @@ static void instantiateLocal(Fortran::lower::AbstractConverter &converter,
   assert(!var.isAlias());
   Fortran::lower::StatementContext stmtCtx;
   mapSymbolAttributes(converter, var, symMap, stmtCtx);
+  deallocateIntentOut(converter, var, symMap);
   if (mustBeDefaultInitializedAtRuntime(var))
     defaultInitializeAtRuntime(converter, var, symMap);
 }

diff --git a/flang/test/Lower/intentout-deallocate.f90 b/flang/test/Lower/intentout-deallocate.f90
new file mode 100644 (file)
index 0000000..b754698
--- /dev/null
+++ b/flang/test/Lower/intentout-deallocate.f90
@@ -0,0 +1,145 @@
+! Test correct deallocation of intent(out) allocatables.
+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+module mod1
+  type, bind(c) :: t1
+    integer :: i
+  end type
+
+  interface
+    subroutine sub3(a) bind(c)
+      integer, intent(out), allocatable :: a(:)
+    end subroutine
+  end interface
+
+  interface
+    subroutine sub7(t) bind(c)
+      import :: t1
+      type(t1), allocatable, intent(out) :: t
+    end subroutine
+  end interface
+
+contains
+  subroutine sub0()
+    integer, allocatable :: a(:)
+    allocate(a(10))
+    call sub1(a)
+  end subroutine
+
+  subroutine sub1(a)
+    integer, intent(out), allocatable :: a(:)
+  end subroutine
+
+! Make sure there is no deallocation of the allocatable intent(out) on the
+! caller side.
+
+! CHECK-LABEL: func.func @_QMmod1Psub0()
+! CHECK-NOT: fir.freemem
+! CHECK: fir.call @_QMmod1Psub1
+
+! Check inline deallocation of allocatable intent(out) on the callee side.
+
+! CHECK-LABEL: func.func @_QMmod1Psub1(
+! CHECK-SAME: %[[ARG0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>> {fir.bindc_name = "a"})
+! CHECK: %[[BOX:.*]] = fir.load %[[ARG0]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>
+! CHECK: %[[BOX_ADDR:.*]] = fir.box_addr %[[BOX]] : (!fir.box<!fir.heap<!fir.array<?xi32>>>) -> !fir.heap<!fir.array<?xi32>>
+! CHECK: fir.freemem %[[BOX_ADDR]] : !fir.heap<!fir.array<?xi32>>
+! CHECK: %[[ZERO:.*]] = fir.zero_bits !fir.heap<!fir.array<?xi32>>
+! CHECK: %[[C0:.*]] = arith.constant 0 : index
+! CHECK: %[[SHAPE:.*]] = fir.shape %[[C0]] : (index) -> !fir.shape<1>
+! CHECK: %[[EMBOX:.*]] = fir.embox %[[ZERO]](%[[SHAPE]]) : (!fir.heap<!fir.array<?xi32>>, !fir.shape<1>) -> !fir.box<!fir.heap<!fir.array<?xi32>>>
+! CHECK: fir.store %[[EMBOX]] to %[[ARG0]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>
+
+  subroutine sub2()
+    integer, allocatable :: a(:)
+    allocate(a(10))
+    call sub3(a)
+  end subroutine
+
+! Check inlined deallocation of allocatble intent(out) on the caller side for BIND(C).
+
+! CHECK-LABEL: func.func @_QMmod1Psub2()
+! CHECK: %[[BOX:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?xi32>>> {bindc_name = "a", uniq_name = "_QMmod1Fsub2Ea"}
+! CHECK: %[[BOX_ALLOC:.*]] = fir.alloca !fir.heap<!fir.array<?xi32>> {uniq_name = "_QMmod1Fsub2Ea.addr"}
+! CHECK: %[[LOAD:.*]] = fir.load %[[BOX_ALLOC]] : !fir.ref<!fir.heap<!fir.array<?xi32>>>
+! CHECK: %{{.*}} = fir.embox %[[LOAD]](%{{.*}}) : (!fir.heap<!fir.array<?xi32>>, !fir.shapeshift<
+! CHECK: %[[LOAD:.*]] = fir.load %[[BOX_ALLOC]] : !fir.ref<!fir.heap<!fir.array<?xi32>>>
+! CHECK: fir.freemem %[[LOAD]] : !fir.heap<!fir.array<?xi32>>
+! CHECK: %[[ZERO:.*]] = fir.zero_bits !fir.heap<!fir.array<?xi32>>
+! CHECK: fir.store %[[ZERO]] to %[[BOX_ALLOC]] : !fir.ref<!fir.heap<!fir.array<?xi32>>>
+! CHECK: fir.call @sub3(%[[BOX]]) : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>) -> ()
+
+  subroutine sub4()
+    type(t1), allocatable :: t
+    call sub5(t)
+  end subroutine
+
+  subroutine sub5(t)
+    type(t1), allocatable, intent(out) :: t
+  end subroutine
+
+! Make sure there is no deallocation runtime call of the allocatable intent(out)
+! on the caller side.
+
+! CHECK-LABEL: func.func @_QMmod1Psub4()
+! CHECK: %[[BOX:.*]] = fir.alloca !fir.box<!fir.heap<!fir.type<_QMmod1Tt1{i:i32}>>> {bindc_name = "t", uniq_name = "_QMmod1Fsub4Et"}
+! CHECK-NOT: fir.call @_FortranAAllocatableDeallocate
+! CHECK: fir.call @_QMmod1Psub5(%[[BOX]]) : (!fir.ref<!fir.box<!fir.heap<!fir.type<_QMmod1Tt1{i:i32}>>>>) -> ()
+
+! Check deallocation of allocatble intent(out) on the callee side. Deallocation
+! is done with a runtime call.
+
+! CHECK-LABEL: func.func @_QMmod1Psub5(
+! CHECK-SAME: %[[ARG0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.type<_QMmod1Tt1{i:i32}>>>> {fir.bindc_name = "t"})
+! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[ARG0]] : (!fir.ref<!fir.box<!fir.heap<!fir.type<_QMmod1Tt1{i:i32}>>>>) -> !fir.ref<!fir.box<none>>
+! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocate(%[[BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) : (!fir.ref<!fir.box<none>>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
+
+  subroutine sub6()
+    type(t1), allocatable :: t
+    call sub7(t)
+  end subroutine
+
+! Check deallocation of allocatble intent(out) on the caller side for BIND(C).
+! Deallocation is done with a runtime call.
+
+! CHECK-LABEL: func.func @_QMmod1Psub6()
+! CHECK: %[[BOX:.*]] = fir.alloca !fir.box<!fir.heap<!fir.type<_QMmod1Tt1{i:i32}>>> {bindc_name = "t", uniq_name = "_QMmod1Fsub6Et"}
+! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[BOX]] : (!fir.ref<!fir.box<!fir.heap<!fir.type<_QMmod1Tt1{i:i32}>>>>) -> !fir.ref<!fir.box<none>>
+! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocate(%[[BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) : (!fir.ref<!fir.box<none>>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
+! CHECK: fir.call @sub7(%[[BOX]]) : (!fir.ref<!fir.box<!fir.heap<!fir.type<_QMmod1Tt1{i:i32}>>>>) -> ()
+
+  subroutine sub8()
+    integer, allocatable :: a(:)
+    allocate(a(10))
+    call sub9(a)
+  end subroutine
+
+  subroutine sub9(a)
+    integer, intent(out), allocatable, optional :: a(:)
+  end subroutine
+
+! Make sure there is no deallocation of the allocatable intent(out) on the
+! caller side.
+
+! CHECK-LABEL: func.func @_QMmod1Psub8()
+! CHECK-NOT: fir.freemem
+! CHECK: fir.call @_QMmod1Psub9
+
+! Check inline deallocation of optional allocatable intent(out) on the callee side.
+
+! CHECK-LABEL: func.func @_QMmod1Psub9(
+! CHECK-SAME:  %[[ARG0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>> {fir.bindc_name = "a", fir.optional})
+! CHECK: %[[IS_PRESENT:.*]] = fir.is_present %[[ARG0]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>) -> i1
+! CHECK: fir.if %[[IS_PRESENT]] {
+! CHECK:   %[[BOX:.*]] = fir.load %[[ARG0]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>
+! CHECK:   %[[BOX_ADDR:.*]] = fir.box_addr %[[BOX]] : (!fir.box<!fir.heap<!fir.array<?xi32>>>) -> !fir.heap<!fir.array<?xi32>>
+! CHECK:   fir.freemem %[[BOX_ADDR]] : !fir.heap<!fir.array<?xi32>>
+! CHECK:   %[[ZERO:.*]] = fir.zero_bits !fir.heap<!fir.array<?xi32>>
+! CHECK:   %[[C0:.*]] = arith.constant 0 : index
+! CHECK:   %[[SHAPE:.*]] = fir.shape %[[C0]] : (index) -> !fir.shape<1>
+! CHECK:   %[[EMBOX:.*]] = fir.embox %[[ZERO]](%[[SHAPE]]) : (!fir.heap<!fir.array<?xi32>>, !fir.shape<1>) -> !fir.box<!fir.heap<!fir.array<?xi32>>>
+! CHECK:   fir.store %[[EMBOX]] to %[[ARG0]] : !fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>
+! CHECK: }
+
+end module
+