From ae780be814525d3f61d7cd47558d842155555ba6 Mon Sep 17 00:00:00 2001 From: Peter Klausler Date: Thu, 17 Jul 2025 17:00:20 -0700 Subject: [PATCH] [flang][runtime] Preserve type when remapping monomorphic pointers 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. Fixes https://github.com/llvm/llvm-project/issues/149353. --- .../include/flang-rt/runtime/descriptor.h | 3 ++- flang-rt/lib/runtime/descriptor.cpp | 19 +++++++++++-------- flang-rt/lib/runtime/pointer.cpp | 19 ++++++++++++++++--- flang/include/flang/Lower/Runtime.h | 2 +- .../Optimizer/Builder/Runtime/Intrinsics.h | 2 +- flang/include/flang/Runtime/pointer.h | 5 +++++ flang/lib/Lower/Bridge.cpp | 6 ++++-- flang/lib/Lower/Runtime.cpp | 15 ++++++++------- flang/test/Lower/polymorphic.f90 | 11 +++++++++++ 9 files changed, 59 insertions(+), 23 deletions(-) diff --git a/flang-rt/include/flang-rt/runtime/descriptor.h b/flang-rt/include/flang-rt/runtime/descriptor.h index 68106f3462c9b..bc5a5b5f14697 100644 --- a/flang-rt/include/flang-rt/runtime/descriptor.h +++ b/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; diff --git a/flang-rt/lib/runtime/descriptor.cpp b/flang-rt/lib/runtime/descriptor.cpp index b723acdd27bd5..e735116bc7c28 100644 --- a/flang-rt/lib/runtime/descriptor.cpp +++ b/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()); + } } } } diff --git a/flang-rt/lib/runtime/pointer.cpp b/flang-rt/lib/runtime/pointer.cpp index 04487abd3272e..68db2594acdd4 100644 --- a/flang-rt/lib/runtime/pointer.cpp +++ b/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(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. diff --git a/flang/include/flang/Lower/Runtime.h b/flang/include/flang/Lower/Runtime.h index 77e98a1e019e7..f76f398569b54 100644 --- a/flang/include/flang/Lower/Runtime.h +++ b/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); diff --git a/flang/include/flang/Optimizer/Builder/Runtime/Intrinsics.h b/flang/include/flang/Optimizer/Builder/Runtime/Intrinsics.h index 9ca4b2baeaa65..145ea04e56484 100644 --- a/flang/include/flang/Optimizer/Builder/Runtime/Intrinsics.h +++ b/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, diff --git a/flang/include/flang/Runtime/pointer.h b/flang/include/flang/Runtime/pointer.h index 83472ee59d2ab..6787ef3ece232 100644 --- a/flang/include/flang/Runtime/pointer.h +++ b/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 diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp index 33c1f1e7a3c3a..d642be08444a3 100644 --- a/flang/lib/Lower/Bridge.cpp +++ b/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()) { diff --git a/flang/lib/Lower/Runtime.cpp b/flang/lib/Lower/Runtime.cpp index 2be5ef76e46b8..5b3412ca5e65c 100644 --- a/flang/lib/Lower/Runtime.cpp +++ b/flang/lib/Lower/Runtime.cpp @@ -213,14 +213,15 @@ void Fortran::lower::genPointerAssociate(fir::FirOpBuilder &builder, builder.create(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(loc, - builder); + isMonomorphic + ? fir::runtime::getRuntimeFunc(loc, builder) + : fir::runtime::getRuntimeFunc( + loc, builder); auto fTy = func.getFunctionType(); auto sourceFile = fir::factory::locationToFilename(builder, loc); auto sourceLine = diff --git a/flang/test/Lower/polymorphic.f90 b/flang/test/Lower/polymorphic.f90 index b7be5f685d9e3..1c1bc78e9b34a 100644 --- a/flang/test/Lower/polymorphic.f90 +++ b/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.