[flang][runtime] Preserve type when remapping monomorphic pointers (#149427)

Pointer remappings unconditionally update the element byte size and
derived type of the pointer's descriptor. This is okay when the pointer
is polymorphic, but not when a pointer is associated with an extended
type.

To communicate this monomorphic case to the runtime, add a new entry
point so as to not break forward binary compatibility.

Author: klausler

flang-rt/include/flang-rt/runtime/descriptor.h

@@ -478,7 +478,8 @@ class Descriptor {
       const SubscriptValue *upper = nullptr,
       const SubscriptValue *stride = nullptr);
 
-  RT_API_ATTRS void ApplyMold(const Descriptor &, int rank);
+  RT_API_ATTRS void ApplyMold(
+      const Descriptor &, int rank, bool isMonomorphic = false);
 
   RT_API_ATTRS void Check() const;
 

flang-rt/lib/runtime/descriptor.cpp

@@ -252,18 +252,21 @@ RT_API_ATTRS bool Descriptor::EstablishPointerSection(const Descriptor &source,
   return CFI_section(&raw_, &source.raw_, lower, upper, stride) == CFI_SUCCESS;
 }
 
-RT_API_ATTRS void Descriptor::ApplyMold(const Descriptor &mold, int rank) {
-  raw_.elem_len = mold.raw_.elem_len;
+RT_API_ATTRS void Descriptor::ApplyMold(
+    const Descriptor &mold, int rank, bool isMonomorphic) {
   raw_.rank = rank;
-  raw_.type = mold.raw_.type;
   for (int j{0}; j < rank && j < mold.raw_.rank; ++j) {
     GetDimension(j) = mold.GetDimension(j);
   }
-  if (auto *addendum{Addendum()}) {
-    if (auto *moldAddendum{mold.Addendum()}) {
-      *addendum = *moldAddendum;
-    } else {
-      INTERNAL_CHECK(!addendum->derivedType());
+  if (!isMonomorphic) {
+    raw_.elem_len = mold.raw_.elem_len;
+    raw_.type = mold.raw_.type;
+    if (auto *addendum{Addendum()}) {
+      if (auto *moldAddendum{mold.Addendum()}) {
+        *addendum = *moldAddendum;
+      } else {
+        INTERNAL_CHECK(!addendum->derivedType());
+      }
     }
   }
 }

flang-rt/lib/runtime/pointer.cpp

@@ -87,9 +87,9 @@ void RTDEF(PointerAssociateLowerBounds)(Descriptor &pointer,
   }
 }
 
-void RTDEF(PointerAssociateRemapping)(Descriptor &pointer,
+static void RT_API_ATTRS PointerRemapping(Descriptor &pointer,
     const Descriptor &target, const Descriptor &bounds, const char *sourceFile,
-    int sourceLine) {
+    int sourceLine, bool isMonomorphic) {
   Terminator terminator{sourceFile, sourceLine};
   SubscriptValue byteStride{/*captured from first dimension*/};
   std::size_t boundElementBytes{bounds.ElementBytes()};
@@ -99,7 +99,7 @@ void RTDEF(PointerAssociateRemapping)(Descriptor &pointer,
   // the ranks may mismatch. Use target as a mold for initializing
   // the pointer descriptor.
   INTERNAL_CHECK(static_cast<std::size_t>(pointer.rank()) == boundsRank);
-  pointer.ApplyMold(target, boundsRank);
+  pointer.ApplyMold(target, boundsRank, isMonomorphic);
   pointer.set_base_addr(target.raw().base_addr);
   pointer.raw().attribute = CFI_attribute_pointer;
   for (unsigned j{0}; j < boundsRank; ++j) {
@@ -124,6 +124,19 @@ void RTDEF(PointerAssociateRemapping)(Descriptor &pointer,
   }
 }
 
+void RTDEF(PointerAssociateRemapping)(Descriptor &pointer,
+    const Descriptor &target, const Descriptor &bounds, const char *sourceFile,
+    int sourceLine) {
+  PointerRemapping(
+      pointer, target, bounds, sourceFile, sourceLine, /*isMonomorphic=*/false);
+}
+void RTDEF(PointerAssociateRemappingMonomorphic)(Descriptor &pointer,
+    const Descriptor &target, const Descriptor &bounds, const char *sourceFile,
+    int sourceLine) {
+  PointerRemapping(
+      pointer, target, bounds, sourceFile, sourceLine, /*isMonomorphic=*/true);
+}
+
 RT_API_ATTRS void *AllocateValidatedPointerPayload(
     std::size_t byteSize, int allocatorIdx) {
   // Add space for a footer to validate during deallocation.

flang/include/flang/Lower/Runtime.h

@@ -70,7 +70,7 @@ void genPointerAssociate(fir::FirOpBuilder &, mlir::Location,
                          mlir::Value pointer, mlir::Value target);
 void genPointerAssociateRemapping(fir::FirOpBuilder &, mlir::Location,
                                   mlir::Value pointer, mlir::Value target,
-                                  mlir::Value bounds);
+                                  mlir::Value bounds, bool isMonomorphic);
 void genPointerAssociateLowerBounds(fir::FirOpBuilder &, mlir::Location,
                                     mlir::Value pointer, mlir::Value target,
                                     mlir::Value lbounds);

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

@@ -37,7 +37,7 @@ void genPointerAssociate(fir::FirOpBuilder &, mlir::Location,
                          mlir::Value pointer, mlir::Value target);
 void genPointerAssociateRemapping(fir::FirOpBuilder &, mlir::Location,
                                   mlir::Value pointer, mlir::Value target,
-                                  mlir::Value bounds);
+                                  mlir::Value bounds, bool isMonomorphic);
 
 mlir::Value genCpuTime(fir::FirOpBuilder &, mlir::Location);
 void genDateAndTime(fir::FirOpBuilder &, mlir::Location,

flang/include/flang/Runtime/pointer.h

@@ -59,9 +59,14 @@ void RTDECL(PointerAssociateLowerBounds)(
 // Associates a pointer with a target with bounds remapping.  The target must be
 // simply contiguous &/or of rank 1.  The bounds constitute a [2,newRank]
 // integer array whose columns are [lower bound, upper bound] on each dimension.
+// Use the Monomorphic form if the pointer's type shouldn't change and
+// the target is polymorphic.
 void RTDECL(PointerAssociateRemapping)(Descriptor &, const Descriptor &target,
     const Descriptor &bounds, const char *sourceFile = nullptr,
     int sourceLine = 0);
+void RTDECL(PointerAssociateRemappingMonomorphic)(Descriptor &,
+    const Descriptor &target, const Descriptor &bounds,
+    const char *sourceFile = nullptr, int sourceLine = 0);
 
 // Data pointer allocation and deallocation
 

flang/lib/Lower/Bridge.cpp

@@ -4703,8 +4703,10 @@ class FirConverter : public Fortran::lower::AbstractConverter {
       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);
+      Fortran::lower::genPointerAssociateRemapping(
+          *builder, loc, lhs, rhs, boundsDesc,
+          lhsType && rhsType && !lhsType->IsPolymorphic() &&
+              rhsType->IsPolymorphic());
       return;
     }
     if (!lowerToHighLevelFIR() && explicitIterationSpace()) {

flang/lib/Lower/Runtime.cpp

@@ -213,14 +213,15 @@ void Fortran::lower::genPointerAssociate(fir::FirOpBuilder &builder,
   builder.create<fir::CallOp>(loc, func, args);
 }
 
-void Fortran::lower::genPointerAssociateRemapping(fir::FirOpBuilder &builder,
-                                                  mlir::Location loc,
-                                                  mlir::Value pointer,
-                                                  mlir::Value target,
-                                                  mlir::Value bounds) {
+void Fortran::lower::genPointerAssociateRemapping(
+    fir::FirOpBuilder &builder, mlir::Location loc, mlir::Value pointer,
+    mlir::Value target, mlir::Value bounds, bool isMonomorphic) {
   mlir::func::FuncOp func =
-      fir::runtime::getRuntimeFunc<mkRTKey(PointerAssociateRemapping)>(loc,
-                                                                       builder);
+      isMonomorphic
+          ? fir::runtime::getRuntimeFunc<mkRTKey(
+                PointerAssociateRemappingMonomorphic)>(loc, builder)
+          : fir::runtime::getRuntimeFunc<mkRTKey(PointerAssociateRemapping)>(
+                loc, builder);
   auto fTy = func.getFunctionType();
   auto sourceFile = fir::factory::locationToFilename(builder, loc);
   auto sourceLine =

flang/test/Lower/polymorphic.f90

@@ -178,6 +178,17 @@ subroutine polymorphic_to_nonpolymorphic(p)
 ! CHECK-LABEL: func.func @_QMpolymorphic_testPpolymorphic_to_nonpolymorphic
 ! Just checking that FIR is generated without error.
 
+  subroutine nonpolymorphic_to_polymorphic(p, t)
+    type p1
+    end type
+    type(p1), pointer :: p(:)
+    class(p1), target :: t(:)
+    p(0:1) => t
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMpolymorphic_testPnonpolymorphic_to_polymorphic
+! CHECK: fir.call @_FortranAPointerAssociateRemappingMonomorphic
+
 ! Test that lowering does not crash for function return with unlimited
 ! polymoprhic value.