diff --git a/flang/include/flang/Optimizer/Builder/MutableBox.h b/flang/include/flang/Optimizer/Builder/MutableBox.h --- a/flang/include/flang/Optimizer/Builder/MutableBox.h +++ b/flang/include/flang/Optimizer/Builder/MutableBox.h @@ -74,7 +74,8 @@ /// previously associated/allocated. The function generates code that sets the /// address field of the MutableBoxValue to zero. void disassociateMutableBox(fir::FirOpBuilder &builder, mlir::Location loc, - const fir::MutableBoxValue &box); + const fir::MutableBoxValue &box, + bool polymorphicSetType = true); /// Generate code to conditionally reallocate a MutableBoxValue with a new /// shape, lower bounds, and LEN parameters if it is unallocated or if its diff --git a/flang/include/flang/Optimizer/Builder/Runtime/Derived.h b/flang/include/flang/Optimizer/Builder/Runtime/Derived.h --- a/flang/include/flang/Optimizer/Builder/Runtime/Derived.h +++ b/flang/include/flang/Optimizer/Builder/Runtime/Derived.h @@ -16,6 +16,7 @@ namespace fir { class FirOpBuilder; +class RecordType; } namespace fir::runtime { @@ -30,5 +31,11 @@ void genDerivedTypeDestroy(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Value box); +/// Generate call to `PointerNullifyDerived` runtime function to nullify +/// and set the correct dynamic type to a boxed derived type. +void genNullifyDerivedType(fir::FirOpBuilder &builder, mlir::Location loc, + mlir::Value box, fir::RecordType derivedType, + unsigned rank = 0); + } // namespace fir::runtime #endif // FORTRAN_OPTIMIZER_BUILDER_RUNTIME_DERIVED_H 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 @@ -720,7 +720,8 @@ fir::MutableBoxValue box(boxAddr, nonDeferredParams, mutableProperties); fir::FirOpBuilder &builder = converter.getFirOpBuilder(); if (!var.isGlobal() && !Fortran::semantics::IsDummy(var.getSymbol())) - fir::factory::disassociateMutableBox(builder, loc, box); + fir::factory::disassociateMutableBox(builder, loc, box, + /*polymorphicSetType=*/false); return box; } diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp --- a/flang/lib/Lower/Bridge.cpp +++ b/flang/lib/Lower/Bridge.cpp @@ -32,6 +32,7 @@ #include "flang/Optimizer/Builder/Character.h" #include "flang/Optimizer/Builder/FIRBuilder.h" #include "flang/Optimizer/Builder/Runtime/Character.h" +#include "flang/Optimizer/Builder/Runtime/Derived.h" #include "flang/Optimizer/Builder/Runtime/EnvironmentDefaults.h" #include "flang/Optimizer/Builder/Runtime/Ragged.h" #include "flang/Optimizer/Builder/Todo.h" diff --git a/flang/lib/Optimizer/Builder/MutableBox.cpp b/flang/lib/Optimizer/Builder/MutableBox.cpp --- a/flang/lib/Optimizer/Builder/MutableBox.cpp +++ b/flang/lib/Optimizer/Builder/MutableBox.cpp @@ -646,7 +646,18 @@ void fir::factory::disassociateMutableBox(fir::FirOpBuilder &builder, mlir::Location loc, - const fir::MutableBoxValue &box) { + const fir::MutableBoxValue &box, + bool polymorphicSetType) { + if (box.isPolymorphic() && polymorphicSetType) { + // 7.3.2.3 point 7. The dynamic type of a disassociated pointer is the + // same as its declared type. + auto boxTy = box.getBoxTy().dyn_cast(); + auto eleTy = fir::dyn_cast_ptrOrBoxEleTy(boxTy.getEleTy()); + if (auto recTy = eleTy.dyn_cast()) + fir::runtime::genNullifyDerivedType(builder, loc, box.getAddr(), recTy, + box.rank()); + return; + } MutablePropertyWriter{builder, loc, box}.setUnallocatedStatus(); } diff --git a/flang/lib/Optimizer/Builder/Runtime/Derived.cpp b/flang/lib/Optimizer/Builder/Runtime/Derived.cpp --- a/flang/lib/Optimizer/Builder/Runtime/Derived.cpp +++ b/flang/lib/Optimizer/Builder/Runtime/Derived.cpp @@ -9,7 +9,10 @@ #include "flang/Optimizer/Builder/Runtime/Derived.h" #include "flang/Optimizer/Builder/FIRBuilder.h" #include "flang/Optimizer/Builder/Runtime/RTBuilder.h" +#include "flang/Optimizer/Support/FatalError.h" +#include "flang/Optimizer/Support/InternalNames.h" #include "flang/Runtime/derived-api.h" +#include "flang/Runtime/pointer.h" using namespace Fortran::runtime; @@ -33,3 +36,29 @@ auto args = fir::runtime::createArguments(builder, loc, fTy, box); builder.create(loc, func, args); } + +void fir::runtime::genNullifyDerivedType(fir::FirOpBuilder &builder, + mlir::Location loc, mlir::Value box, + fir::RecordType derivedType, + unsigned rank) { + std::string typeDescName = + fir::NameUniquer::getTypeDescriptorName(derivedType.getName()); + fir::GlobalOp typeDescGlobal = builder.getNamedGlobal(typeDescName); + if (!typeDescGlobal) + fir::emitFatalError(loc, "no type descriptor found for NULLIFY"); + auto typeDescAddr = builder.create( + loc, fir::ReferenceType::get(typeDescGlobal.getType()), + typeDescGlobal.getSymbol()); + mlir::func::FuncOp callee = + fir::runtime::getRuntimeFunc(loc, + builder); + llvm::ArrayRef inputTypes = callee.getFunctionType().getInputs(); + llvm::SmallVector args; + args.push_back(builder.createConvert(loc, inputTypes[0], box)); + args.push_back(builder.createConvert(loc, inputTypes[1], typeDescAddr)); + mlir::Value rankCst = builder.createIntegerConstant(loc, inputTypes[2], rank); + mlir::Value c0 = builder.createIntegerConstant(loc, inputTypes[3], 0); + args.push_back(rankCst); + args.push_back(c0); + builder.create(loc, callee, args); +} diff --git a/flang/test/Lower/nullify-polymoprhic.f90 b/flang/test/Lower/nullify-polymoprhic.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/nullify-polymoprhic.f90 @@ -0,0 +1,53 @@ +! RUN: bbc -polymorphic-type -emit-fir %s -o - | FileCheck %s + +module poly + type p1 + integer :: a + integer :: b + contains + procedure, nopass :: proc1 => proc1_p1 + end type + + type, extends(p1) :: p2 + integer :: c + contains + procedure, nopass :: proc1 => proc1_p2 + end type + +contains + + subroutine proc1_p1() + print*, 'call proc1_p1' + end subroutine + + subroutine proc1_p2() + print*, 'call proc1_p2' + end subroutine + + subroutine test_nullify() + class(p1), pointer :: c + + allocate(p2::c) + call c%proc1() + + nullify(c) ! c dynamic type must be reset to p1 + + call c%proc1() + end subroutine +end module + +program test + use poly + call test_nullify() +end + +! CHECK-LABEL: func.func @_QMpolyPtest_nullify() +! CHECK: %[[C_DESC:.*]] = fir.alloca !fir.class>> {bindc_name = "c", uniq_name = "_QMpolyFtest_nullifyEc"} +! CHECK: %[[C_ADDR:.*]] = fir.alloca !fir.ptr> {uniq_name = "_QMpolyFtest_nullifyEc.addr"} +! CHECK: %{{.*}} = fir.call @_FortranAPointerAllocate(%{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) : (!fir.ref>, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[DECLARED_TYPE:.*]] = fir.address_of(@_QMpolyE.dt.p1) : !fir.ref> +! CHECK: %[[C_DESC_CAST:.*]] = fir.convert %[[C_DESC]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[TYPE_DESC_CAST:.*]] = fir.convert %[[DECLARED_TYPE]] : (!fir.ref>) -> !fir.ref +! CHECK: %[[RANK:.*]] = arith.constant 0 : i32 +! CHECK: %[[CORANK:.*]] = arith.constant 0 : i32 +! CHECK: %{{.*}} = fir.call @_FortranAPointerNullifyDerived(%[[C_DESC_CAST]], %[[TYPE_DESC_CAST]], %[[RANK]], %[[CORANK]]) : (!fir.ref>, !fir.ref, i32, i32) -> none