[flang] Set declared type when NULLIFY a polymorphic pointer

[clementval]

Summary

Fortran standard 7.3.2.3 point 7 mentions that a diassociated
pointer dynamic type is its declared type.
in 9.7.2 note 1, when a NULLIFY statement is applied to a polymorphic pointer,
its dynamic type becomes the same as its declared type.
This patch enforce these standard points by calling the runtime function
PointerNullifyDerived with the declared type descriptor.

[jeanPerier]

flang/lib/Lower/Bridge.cpp

2207

I am not sure what are the requirements for the other cases where "disassociateMutableBox" is called (like for p => Null), but I am wondering if this should not be done in disassociateMutableBox.
I am OK to have this only done here until it is clear what are the requirements for the other contexts where it is called.

2214

Shouldn't you "continue" the loop here to not call disassociateMutableBox ?

[clementval]

flang/lib/Lower/Bridge.cpp

2207

The standard is not really precise on this point but I think it can make sense to do it anyway. I'll move it to disassociateMutableBox so it is a more generic.

2214

Yeah we can skip it since the runtime function does the same.

[clementval]

Address review comment

[jeanPerier]

LGTM

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

void associateMutableBoxWithRemap(fir::FirOpBuilder &builder,
                                   mlir::ValueRange lbounds,
                                   mlir::ValueRange ubounds);
 
 /// Set the association status of a MutableBoxValue to
 /// disassociated/unallocated. Nothing is done with the entity that was
 /// 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
 /// current shape or deferred  LEN parameters do not match the provided ones.
 /// Lower bounds are only used if the entity needs to be allocated, otherwise,
 /// the MutableBoxValue will keep its current lower bounds.
 /// If the MutableBoxValue is an array, the provided shape can be empty, in
 /// which case the MutableBoxValue must already be allocated at runtime and its

flang/include/flang/Optimizer/Builder/Runtime/Derived.h

 
 namespace mlir {
 class Value;
 class Location;
 } // namespace mlir
 
 namespace fir {
 class FirOpBuilder;
+class RecordType;
 }
 
 namespace fir::runtime {
 
 /// Generate call to derived type initialization runtime routine to
 /// default initialize \p box.
 void genDerivedTypeInitialize(fir::FirOpBuilder &builder, mlir::Location loc,
                               mlir::Value box);
 
 /// Generate call to derived type destruction runtime routine to
 /// destroy \p box.
 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

flang/lib/Lower/Allocatable.cpp

fir::MutableBoxValue Fortran::lower::createMutableBox(
     const Fortran::lower::pft::Variable &var, mlir::Value boxAddr,
     mlir::ValueRange nonDeferredParams) {
 
   fir::MutableProperties mutableProperties =
       createMutableProperties(converter, loc, var, nonDeferredParams);
   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;
 }
 
 //===----------------------------------------------------------------------===//
 // MutableBoxValue reading interface implementation
 //===----------------------------------------------------------------------===//
 
 bool Fortran::lower::isArraySectionWithoutVectorSubscript(

flang/lib/Lower/Bridge.cpp

 #include "flang/Lower/PFTBuilder.h"
 #include "flang/Lower/Runtime.h"
 #include "flang/Lower/StatementContext.h"
 #include "flang/Lower/Support/Utils.h"
 #include "flang/Optimizer/Builder/BoxValue.h"
 #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"
 #include "flang/Optimizer/Dialect/FIRAttr.h"
 #include "flang/Optimizer/Dialect/FIRDialect.h"
 #include "flang/Optimizer/Dialect/FIROps.h"
 #include "flang/Optimizer/Support/FIRContext.h"
 #include "flang/Optimizer/Support/FatalError.h"

   /// We do this by setting each pointer to null.
   void genFIR(const Fortran::parser::NullifyStmt &stmt) {
     mlir::Location loc = toLocation();
     for (auto &pointerObject : stmt.v) {
       const Fortran::lower::SomeExpr *expr =
           Fortran::semantics::GetExpr(pointerObject);
       assert(expr);
       fir::MutableBoxValue box = genExprMutableBox(loc, *expr);
       fir::factory::disassociateMutableBox(*builder, loc, box);
     }
   }
 
   //===--------------------------------------------------------------------===//
 
   void genFIR(const Fortran::parser::EventPostStmt &stmt) {
     genEventPostStatement(*this, stmt);
   }
 
   void genFIR(const Fortran::parser::EventWaitStmt &stmt) {
     genEventWaitStatement(*this, stmt);
   }
 
   void genFIR(const Fortran::parser::FormTeamStmt &stmt) {
     genFormTeamStatement(*this, getEval(), stmt);

flang/lib/Optimizer/Builder/MutableBox.cpp

source.match(
       },
       [&](const fir::ProcBoxValue &) {
         TODO(loc, "procedure pointer assignment");
       });
 }
 
 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<fir::BaseBoxType>();
+    auto eleTy = fir::dyn_cast_ptrOrBoxEleTy(boxTy.getEleTy());
+    if (auto recTy = eleTy.dyn_cast<fir::RecordType>())
+      fir::runtime::genNullifyDerivedType(builder, loc, box.getAddr(), recTy,
+                                          box.rank());
+    return;
+  }
   MutablePropertyWriter{builder, loc, box}.setUnallocatedStatus();
 }
 
 static llvm::SmallVector<mlir::Value>
 getNewLengths(fir::FirOpBuilder &builder, mlir::Location loc,
               const fir::MutableBoxValue &box, mlir::ValueRange lenParams) {
   llvm::SmallVector<mlir::Value> lengths;
   auto idxTy = builder.getIndexType();

flang/lib/Optimizer/Builder/Runtime/Derived.cpp

 //===-- Derived.cpp -- derived type runtime API ---------------------------===//
 //
 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
 // See https://llvm.org/LICENSE.txt for license information.
 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
 //
 //===----------------------------------------------------------------------===//
 
 #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;
 
 void fir::runtime::genDerivedTypeInitialize(fir::FirOpBuilder &builder,
                                             mlir::Location loc,
                                             mlir::Value box) {
   auto func = fir::runtime::getRuntimeFunc<mkRTKey(Initialize)>(loc, builder);
   auto fTy = func.getFunctionType();
   auto sourceFile = fir::factory::locationToFilename(builder, loc);
   auto sourceLine =
       fir::factory::locationToLineNo(builder, loc, fTy.getInput(2));
   auto args = fir::runtime::createArguments(builder, loc, fTy, box, sourceFile,
                                             sourceLine);
   builder.create<fir::CallOp>(loc, func, args);
 }
 
 void fir::runtime::genDerivedTypeDestroy(fir::FirOpBuilder &builder,
                                          mlir::Location loc, mlir::Value box) {
   auto func = fir::runtime::getRuntimeFunc<mkRTKey(Destroy)>(loc, builder);
   auto fTy = func.getFunctionType();
   auto args = fir::runtime::createArguments(builder, loc, fTy, box);
   builder.create<fir::CallOp>(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<fir::AddrOfOp>(
+      loc, fir::ReferenceType::get(typeDescGlobal.getType()),
+      typeDescGlobal.getSymbol());
+  mlir::func::FuncOp callee =
+      fir::runtime::getRuntimeFunc<mkRTKey(PointerNullifyDerived)>(loc,
+                                                                   builder);
+  llvm::ArrayRef<mlir::Type> inputTypes = callee.getFunctionType().getInputs();
+  llvm::SmallVector<mlir::Value> 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<fir::CallOp>(loc, callee, args);
+}

flang/test/Lower/nullify-polymoprhic.f90

+! 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<!fir.ptr<!fir.type<_QMpolyTp1{a:i32,b:i32}>>> {bindc_name = "c", uniq_name = "_QMpolyFtest_nullifyEc"}
+! CHECK: %[[C_ADDR:.*]] = fir.alloca !fir.ptr<!fir.type<_QMpolyTp1{a:i32,b:i32}>> {uniq_name = "_QMpolyFtest_nullifyEc.addr"}
+! CHECK: %{{.*}} = fir.call @_FortranAPointerAllocate(%{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) : (!fir.ref<!fir.box<none>>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
+! CHECK: %[[DECLARED_TYPE:.*]] = fir.address_of(@_QMpolyE.dt.p1) : !fir.ref<!fir.type<{{.*}}>>
+! CHECK: %[[C_DESC_CAST:.*]] = fir.convert %[[C_DESC]] : (!fir.ref<!fir.class<!fir.ptr<!fir.type<_QMpolyTp1{a:i32,b:i32}>>>>) -> !fir.ref<!fir.box<none>>
+! CHECK: %[[TYPE_DESC_CAST:.*]] = fir.convert %[[DECLARED_TYPE]] : (!fir.ref<!fir.type<{{.*}}>>) -> !fir.ref<none>
+! 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.box<none>>, !fir.ref<none>, i32, i32) -> none