[flang] Set declared type when NULLIFY a polymorphic pointer

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.

Reviewed By: jeanPerier

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

7 files changed, 106 insertions, 3 deletions

diff --git a/flang/include/flang/Optimizer/Builder/MutableBox.h b/flang/include/flang/Optimizer/Builder/MutableBox.h
index 3d04bbf..95083df 100644
--- a/flang/include/flang/Optimizer/Builder/MutableBox.h
+++ b/flang/include/flang/Optimizer/Builder/MutableBox.h
@@ -74,7 +74,8 @@ void associateMutableBoxWithRemap(fir::FirOpBuilder &builder,
 /// 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
index a5e1083..816d561 100644
--- a/flang/include/flang/Optimizer/Builder/Runtime/Derived.h
+++ b/flang/include/flang/Optimizer/Builder/Runtime/Derived.h
@@ -16,6 +16,7 @@ class Location;
 
 namespace fir {
 class FirOpBuilder;
+class RecordType;
 }
 
 namespace fir::runtime {
@@ -30,5 +31,11 @@ void genDerivedTypeInitialize(fir::FirOpBuilder &builder, mlir::Location loc,
 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
index c454fcb..57d4ae1 100644
--- a/flang/lib/Lower/Allocatable.cpp
+++ b/flang/lib/Lower/Allocatable.cpp
@@ -720,7 +720,8 @@ fir::MutableBoxValue Fortran::lower::createMutableBox(
   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
index db8c2b7..46df999 100644
--- 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
index d2f3b21..d1fc09c 100644
--- a/flang/lib/Optimizer/Builder/MutableBox.cpp
+++ b/flang/lib/Optimizer/Builder/MutableBox.cpp
@@ -646,7 +646,18 @@ void fir::factory::associateMutableBoxWithRemap(
 
 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();
 }
 
diff --git a/flang/lib/Optimizer/Builder/Runtime/Derived.cpp b/flang/lib/Optimizer/Builder/Runtime/Derived.cpp
index 0f2bf27..8700c9e 100644
--- 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 @@ void fir::runtime::genDerivedTypeDestroy(fir::FirOpBuilder &builder,
   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);
+}
diff --git a/flang/test/Lower/nullify-polymoprhic.f90 b/flang/test/Lower/nullify-polymoprhic.f90
new file mode 100644
index 0000000..7c9ac9c
--- /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<!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