[flang] preserve pointer rank in polymorphic_pointer => NULL()

[jeanPerier]

Summary

The current lowering for polymorphic pointer association was not
dealing with NULL in a "context aware" fashion: it was calling the
PointerAssociate runtime entry point with a fir.box<none> target.
But the fir.box<none> is a descriptor for a scalar, this lead the
runtime to set the pointer rank to zero, regardless of its actual
rank.

I do not think there is a way to expose this problem with the Fortran
code currently supported by flang, because most further manipulation of
the pointer would either set the rank correctly, or do not rely on the
rank in the runtime descriptor.

However, this is incorrect, and when assumed rank are supported, the
following would have failed:

subroutine check_rank(p)
  class(*), pointer :: p(..)
  p => null()
  select rank(p)
  rank (1)
   print *, "OK"
  rank default
   print *, "FAILED"
  end select
end subroutine
  class(*), pointer :: p(:)
  p => null()
  call check_rank(p)
end

Instead, detect NULL() in polymorphic pointer lowering and trigger the
deallocation of the pointer.

[clementval]

LGTM

flang/lib/Lower/Bridge.cpp

void genPointerAssignment(
     // course base_addr might need to be updated.
     if (lhsType && lhsType->IsPolymorphic()) {
       if (!lowerToHighLevelFIR() && explicitIterationSpace())
         TODO(loc, "polymorphic pointer assignment in FORALL");
       llvm::SmallVector<mlir::Value> lbounds;
       for (const Fortran::evaluate::ExtentExpr &lbExpr : lbExprs)
         lbounds.push_back(
             fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx)));
-      mlir::Value lhs = genExprMutableBox(loc, assign.lhs).getAddr();
+      fir::MutableBoxValue lhsMutableBox = genExprMutableBox(loc, assign.lhs);
+      if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
+              assign.rhs)) {
+        fir::factory::disassociateMutableBox(*builder, loc, lhsMutableBox);
+        return;
+      }
+      mlir::Value lhs = lhsMutableBox.getAddr();
       mlir::Value rhs = fir::getBase(genExprBox(loc, assign.rhs, stmtCtx));
       if (!lbounds.empty()) {
         mlir::Value boundsDesc = createLboundArray(lbounds, loc);
         Fortran::lower::genPointerAssociateLowerBounds(*builder, loc, lhs, rhs,
                                                        boundsDesc);
         return;
       }
       Fortran::lower::genPointerAssociate(*builder, loc, lhs, rhs);
void genPointerAssignment(
     std::optional<Fortran::evaluate::DynamicType> rhsType =
         assign.rhs.GetType();
     // Polymorphic lhs/rhs need more care. See F2018 10.2.2.3.
     if ((lhsType && lhsType->IsPolymorphic()) ||
         (rhsType && rhsType->IsPolymorphic())) {
       if (!lowerToHighLevelFIR() && explicitIterationSpace())
         TODO(loc, "polymorphic pointer assignment in FORALL");
 
-      mlir::Value lhs = genExprMutableBox(loc, assign.lhs).getAddr();
+      fir::MutableBoxValue lhsMutableBox = genExprMutableBox(loc, assign.lhs);
+      if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
+              assign.rhs)) {
+        fir::factory::disassociateMutableBox(*builder, loc, lhsMutableBox);
+        return;
+      }
+      mlir::Value lhs = lhsMutableBox.getAddr();
       mlir::Value rhs = fir::getBase(genExprBox(loc, assign.rhs, stmtCtx));
       mlir::Value boundsDesc = createBoundArray(lbounds, ubounds, loc);
       Fortran::lower::genPointerAssociateRemapping(*builder, loc, lhs, rhs,
                                                    boundsDesc);
       return;
     }
     if (!lowerToHighLevelFIR() && explicitIterationSpace()) {
       // Pointer assignment in FORALL context. Copy the rhs box value

flang/lib/Optimizer/Builder/MutableBox.cpp

void fir::factory::disassociateMutableBox(fir::FirOpBuilder &builder,
                                           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());
     mlir::Type derivedType = fir::getDerivedType(eleTy);
-    if (auto recTy = derivedType.dyn_cast<fir::RecordType>())
+    if (auto recTy = derivedType.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/test/Lower/pointer-disassociate.f90

 ! Test lowering of pointer disassociation
-! RUN: bbc -emit-fir %s -o - | FileCheck %s
+! RUN: bbc -emit-fir --polymorphic-type %s -o - | FileCheck %s
 
 
 ! -----------------------------------------------------------------------------
 !     Test p => NULL()
 ! -----------------------------------------------------------------------------
 
 
 ! CHECK-LABEL: func @_QPtest_scalar(
subroutine test_array_mold(p, x)
   ! CHECK: %[[VAL_5:.*]] = fir.load %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
   ! CHECK: %[[VAL_6:.*]] = arith.constant 0 : index
   ! CHECK: %[[VAL_7:.*]]:3 = fir.box_dims %[[VAL_5]], %[[VAL_6]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>, index) -> (index, index, index)
   ! CHECK: %[[VAL_8:.*]] = fir.shift %[[VAL_7]]#0 : (index) -> !fir.shift<1>
   ! CHECK: %[[VAL_9:.*]] = fir.rebox %[[VAL_5]](%[[VAL_8]]) : (!fir.box<!fir.ptr<!fir.array<?xf32>>>, !fir.shift<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
   ! CHECK: fir.store %[[VAL_9]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
   p => NULL(x)
 end subroutine
+
+subroutine test_polymorphic_null(p)
+  type t
+  end type
+  class(t), pointer :: p(:)
+  p => null()
+end subroutine
+! CHECK-LABEL:   func.func @_QPtest_polymorphic_null(
+! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<!fir.class<!fir.ptr<!fir.array<?x!fir.type<_QFtest_polymorphic_nullTt>>>>>
+! CHECK:  %[[VAL_1:.*]] = fir.address_of(@_QFtest_polymorphic_nullE.dt.t)
+! CHECK:  %[[VAL_2:.*]] = fir.convert %[[VAL_0]] : (!fir.ref<!fir.class<!fir.ptr<!fir.array<?x!fir.type<_QFtest_polymorphic_nullTt>>>>>) -> !fir.ref<!fir.box<none>>
+! CHECK:  %[[VAL_3:.*]] = fir.convert %[[VAL_1]] : (!fir.ref<{{.*}}>) -> !fir.ref<none>
+! CHECK:  %[[VAL_4:.*]] = arith.constant 1 : i32
+! CHECK:  %[[VAL_5:.*]] = arith.constant 0 : i32
+! CHECK:  %[[VAL_6:.*]] = fir.call @_FortranAPointerNullifyDerived(%[[VAL_2]], %[[VAL_3]], %[[VAL_4]], %[[VAL_5]]) {{.*}}: (!fir.ref<!fir.box<none>>, !fir.ref<none>, i32, i32) -> none
+
+subroutine test_unlimited_polymorphic_null(p)
+  class(*), pointer :: p(:)
+  p => null()
+end subroutine
+! CHECK-LABEL:   func.func @_QPtest_unlimited_polymorphic_null(
+! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<!fir.class<!fir.ptr<!fir.array<?xnone>>>>
+! CHECK:  %[[VAL_1:.*]] = fir.zero_bits !fir.ptr<!fir.array<?xnone>>
+! CHECK:  %[[VAL_2:.*]] = arith.constant 0 : index
+! CHECK:  %[[VAL_3:.*]] = fir.shape %[[VAL_2]] : (index) -> !fir.shape<1>
+! CHECK:  %[[VAL_4:.*]] = fir.embox %[[VAL_1]](%[[VAL_3]]) : (!fir.ptr<!fir.array<?xnone>>, !fir.shape<1>) -> !fir.class<!fir.ptr<!fir.array<?xnone>>>
+! CHECK:  fir.store %[[VAL_4]] to %[[VAL_0]] : !fir.ref<!fir.class<!fir.ptr<!fir.array<?xnone>>>>