[flang] Do not perform INTERNAL_CHECK for deallocation of unlimited polymorphic with intrinsic type spec

[clementval]

Summary

When an unlimited polymorphic descriptor is establish for an intrinsic
type spec, the PointerNullifyIntrinsic or AllocatableInitIntrinsic runtime
function is called. These functions do not initialize an addendum with a derivedType.
When the deallocation on this descriptor is performed, the runtime should not
crash if the addendum is not present. This patch updates PointerDeallocatePolymorphic
and AllocatableDeallocatePolymorphic for this use case.

Depends on D141996

[clementval]

Remove extra comment

[jeanPerier]

flang/runtime/allocatable.cpp

158

Just to clarify, was AllocatableInitIntrinsic called when allocating the derived type to an intrinsic type or is it called in other contexts by lowering?

[PeteSteinfeld]

All builds and tests correctly and looks good.

Again, it would be better if there were a test for this in .../llvm-project/flang/unittests/Runtime.

[clementval]

In D142010#4061991, @PeteSteinfeld wrote:

All builds and tests correctly and looks good.

Again, it would be better if there were a test for this in .../llvm-project/flang/unittests/Runtime.

Should be doable for this one. I'll add it.

flang/runtime/allocatable.cpp

158

It is called when you allocate a unlimited polymorphic descriptor with an intrinsic type like:

class(*), allocatable :: p
allocate(integer::p)

[clementval]

Add unit test

[PeteSteinfeld]

Thanks, @clementval, you're the best.

flang/runtime/allocatable.cpp

 
 int RTNAME(AllocatableDeallocatePolymorphic)(Descriptor &descriptor,
     const typeInfo::DerivedType *derivedType, bool hasStat,
     const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
   int stat{RTNAME(AllocatableDeallocate)(
       descriptor, hasStat, errMsg, sourceFile, sourceLine)};
   if (stat == StatOk) {
     DescriptorAddendum *addendum{descriptor.Addendum()};
-    INTERNAL_CHECK(addendum != nullptr);
+    if (addendum) { // Unlimited polymorphic allocated from intrinsic type spec
+                    // does not have
       addendum->set_derivedType(derivedType);
+    } else {
+      // Unlimited polymorphic descriptors initialized with
+      // AllocatableInitIntrinsic do not have an addendum. Make sure the
+      // derivedType is null in that case.
+      INTERNAL_CHECK(!derivedType);
+    }
   }
   return stat;
 }
 
 void RTNAME(AllocatableDeallocateNoFinal)(
     Descriptor &descriptor, const char *sourceFile, int sourceLine) {
   Terminator terminator{sourceFile, sourceLine};
   if (!descriptor.IsAllocatable()) {

flang/runtime/pointer.cpp

 
 int RTNAME(PointerDeallocatePolymorphic)(Descriptor &pointer,
     const typeInfo::DerivedType *derivedType, bool hasStat,
     const Descriptor *errMsg, const char *sourceFile, int sourceLine) {
   int stat{RTNAME(PointerDeallocate)(
       pointer, hasStat, errMsg, sourceFile, sourceLine)};
   if (stat == StatOk) {
     DescriptorAddendum *addendum{pointer.Addendum()};
-    INTERNAL_CHECK(addendum != nullptr);
+    if (addendum) {
       addendum->set_derivedType(derivedType);
+    } else {
+      // Unlimited polymorphic descriptors initialized with
+      // PointerNullifyIntrinsic do not have an addendum. Make sure the
+      // derivedType is null in that case.
+      INTERNAL_CHECK(!derivedType);
+    }
   }
   return stat;
 }
 
 bool RTNAME(PointerIsAssociated)(const Descriptor &pointer) {
   return pointer.raw().base_addr != nullptr;
 }
 

flang/unittests/Runtime/Pointer.cpp

TEST(Pointer, ApplyMoldAllocation) {
 
   RTNAME(PointerApplyMold)(*p, *m);
   RTNAME(PointerAllocate)
   (*p, /*hasStat=*/false, /*errMsg=*/nullptr, __FILE__, __LINE__);
 
   EXPECT_EQ(p->ElementBytes(), m->ElementBytes());
   EXPECT_EQ(p->type(), m->type());
 }
+
+TEST(Pointer, DeallocatePolymorphic) {
+  // CLASS(*) :: p
+  // ALLOCATE(integer::p)
+  auto p{Descriptor::Create(TypeCode{Fortran::common::TypeCategory::Integer, 4},
+      4, nullptr, 0, nullptr, CFI_attribute_pointer)};
+  RTNAME(PointerAllocate)
+  (*p, /*hasStat=*/false, /*errMsg=*/nullptr, __FILE__, __LINE__);
+  // DEALLOCATE(p)
+  RTNAME(PointerDeallocatePolymorphic)
+  (*p, nullptr, /*hasStat=*/false, /*errMsg=*/nullptr, __FILE__, __LINE__);
+}