diff --git a/flang/include/flang/Lower/Allocatable.h b/flang/include/flang/Lower/Allocatable.h --- a/flang/include/flang/Lower/Allocatable.h +++ b/flang/include/flang/Lower/Allocatable.h @@ -48,6 +48,9 @@ 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 --- a/flang/include/flang/Lower/CallInterface.h +++ b/flang/include/flang/Lower/CallInterface.h @@ -159,6 +159,8 @@ 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 --- a/flang/lib/Lower/Allocatable.cpp +++ b/flang/lib/Lower/Allocatable.cpp @@ -523,6 +523,17 @@ 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 --- a/flang/lib/Lower/CallInterface.cpp +++ b/flang/lib/Lower/CallInterface.cpp @@ -1048,6 +1048,12 @@ return true; return characteristics->GetIntent() != Fortran::common::Intent::Out; } +template +bool Fortran::lower::CallInterface::PassedEntity::isIntentOut() const { + if (!characteristics) + return true; + return characteristics->GetIntent() == Fortran::common::Intent::Out; +} template void Fortran::lower::CallInterface::determineInterface( diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp --- a/flang/lib/Lower/ConvertExpr.cpp +++ b/flang/lib/Lower/ConvertExpr.cpp @@ -3239,6 +3239,9 @@ 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 --- a/flang/lib/Lower/ConvertVariable.cpp +++ b/flang/lib/Lower/ConvertVariable.cpp @@ -603,6 +603,38 @@ } } +// 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()) { + mlir::Location loc = converter.getCurrentLocation(); + if (Fortran::semantics::IsOptional(sym)) { + fir::FirOpBuilder &builder = converter.getFirOpBuilder(); + auto isPresent = builder.create( + 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 @@ 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 --- /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.bindc_name = "a"}) +! CHECK: %[[BOX:.*]] = fir.load %[[ARG0]] : !fir.ref>>> +! CHECK: %[[BOX_ADDR:.*]] = fir.box_addr %[[BOX]] : (!fir.box>>) -> !fir.heap> +! CHECK: fir.freemem %[[BOX_ADDR]] : !fir.heap> +! CHECK: %[[ZERO:.*]] = fir.zero_bits !fir.heap> +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[SHAPE:.*]] = fir.shape %[[C0]] : (index) -> !fir.shape<1> +! CHECK: %[[EMBOX:.*]] = fir.embox %[[ZERO]](%[[SHAPE]]) : (!fir.heap>, !fir.shape<1>) -> !fir.box>> +! CHECK: fir.store %[[EMBOX]] to %[[ARG0]] : !fir.ref>>> + + 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>> {bindc_name = "a", uniq_name = "_QMmod1Fsub2Ea"} +! CHECK: %[[BOX_ALLOC:.*]] = fir.alloca !fir.heap> {uniq_name = "_QMmod1Fsub2Ea.addr"} +! CHECK: %[[LOAD:.*]] = fir.load %[[BOX_ALLOC]] : !fir.ref>> +! CHECK: %{{.*}} = fir.embox %[[LOAD]](%{{.*}}) : (!fir.heap>, !fir.shapeshift< +! CHECK: %[[LOAD:.*]] = fir.load %[[BOX_ALLOC]] : !fir.ref>> +! CHECK: fir.freemem %[[LOAD]] : !fir.heap> +! CHECK: %[[ZERO:.*]] = fir.zero_bits !fir.heap> +! CHECK: fir.store %[[ZERO]] to %[[BOX_ALLOC]] : !fir.ref>> +! CHECK: fir.call @sub3(%[[BOX]]) : (!fir.ref>>>) -> () + + 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>> {bindc_name = "t", uniq_name = "_QMmod1Fsub4Et"} +! CHECK-NOT: fir.call @_FortranAAllocatableDeallocate +! CHECK: fir.call @_QMmod1Psub5(%[[BOX]]) : (!fir.ref>>>) -> () + +! 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.bindc_name = "t"}) +! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[ARG0]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocate(%[[BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) : (!fir.ref>, i1, !fir.box, !fir.ref, 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>> {bindc_name = "t", uniq_name = "_QMmod1Fsub6Et"} +! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[BOX]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %{{.*}} = fir.call @_FortranAAllocatableDeallocate(%[[BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: fir.call @sub7(%[[BOX]]) : (!fir.ref>>>) -> () + + 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.bindc_name = "a", fir.optional}) +! CHECK: %[[IS_PRESENT:.*]] = fir.is_present %[[ARG0]] : (!fir.ref>>>) -> i1 +! CHECK: fir.if %[[IS_PRESENT]] { +! CHECK: %[[BOX:.*]] = fir.load %[[ARG0]] : !fir.ref>>> +! CHECK: %[[BOX_ADDR:.*]] = fir.box_addr %[[BOX]] : (!fir.box>>) -> !fir.heap> +! CHECK: fir.freemem %[[BOX_ADDR]] : !fir.heap> +! CHECK: %[[ZERO:.*]] = fir.zero_bits !fir.heap> +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[SHAPE:.*]] = fir.shape %[[C0]] : (index) -> !fir.shape<1> +! CHECK: %[[EMBOX:.*]] = fir.embox %[[ZERO]](%[[SHAPE]]) : (!fir.heap>, !fir.shape<1>) -> !fir.box>> +! CHECK: fir.store %[[EMBOX]] to %[[ARG0]] : !fir.ref>>> +! CHECK: } + +end module +