[flang-commits] [PATCH] D147317: [flang] preserve pointer rank in polymorphic_pointer => NULL()

[Jean Perier via Phabricator via flang-commits]

jeanPerier created this revision.
jeanPerier added reviewers: vzakhari, clementval.
jeanPerier added a project: Flang.
Herald added subscribers: sunshaoce, mehdi_amini, jdoerfert.
Herald added a project: All.
jeanPerier requested review of this revision.

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.


Repository:
  rG LLVM Github Monorepo

https://reviews.llvm.org/D147317

Files:
  flang/lib/Lower/Bridge.cpp
  flang/lib/Optimizer/Builder/MutableBox.cpp
  flang/test/Lower/pointer-disassociate.f90


Index: flang/test/Lower/pointer-disassociate.f90
===================================================================
--- flang/test/Lower/pointer-disassociate.f90
+++ flang/test/Lower/pointer-disassociate.f90
@@ -1,5 +1,5 @@
 ! Test lowering of pointer disassociation
-! RUN: bbc -emit-fir %s -o - | FileCheck %s
+! RUN: bbc -emit-fir --polymorphic-type %s -o - | FileCheck %s
 
 
 ! -----------------------------------------------------------------------------
@@ -104,3 +104,30 @@
   ! 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>>>>
Index: flang/lib/Optimizer/Builder/MutableBox.cpp
===================================================================
--- flang/lib/Optimizer/Builder/MutableBox.cpp
+++ flang/lib/Optimizer/Builder/MutableBox.cpp
@@ -674,10 +674,11 @@
     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;
+      return;
+    }
   }
   MutablePropertyWriter{builder, loc, box}.setUnallocatedStatus();
 }
Index: flang/lib/Lower/Bridge.cpp
===================================================================
--- flang/lib/Lower/Bridge.cpp
+++ flang/lib/Lower/Bridge.cpp
@@ -2828,7 +2828,13 @@
       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);
@@ -2915,7 +2921,13 @@
       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,


-------------- next part --------------
A non-text attachment was scrubbed...
Name: D147317.509994.patch
Type: text/x-patch
Size: 4733 bytes
Desc: not available
URL: <http://lists.llvm.org/pipermail/flang-commits/attachments/20230331/32b757f1/attachment-0001.bin>