[flang-commits] [flang] [llvm] [Flang][OpenMP][WIP] Initial OpenMP 6.1 Polymorpic Mapping Implementation (PR #228747)
via flang-commits
flang-commits at lists.llvm.org
Sat Oct 3 10:20:49 PDT 2026
https://github.com/agozillon updated https://github.com/llvm/llvm-project/pull/228747
>From eab3489b6fbb6ac8257123b6ea7de9e0e203b28b Mon Sep 17 00:00:00 2001
From: agozillon <Andrew.Gozillon at amd.com>
Date: Wed, 23 Sep 2026 20:27:45 -0500
Subject: [PATCH] [Flang][OpenMP][WIP] Initial OpenMP 6.1 Polymorpic Mapping
Implementation
This PR aims to take an initial step towards supporting polymorphic mapping (class)
in Flang OpenMP to target devices. This has predominantly been tested on AMD hardware,
namely an MI300A and MI300X.
The PR aims to add:
- Semantic check for versions <= 6.1 that errors out on polymorphic and unlimited
polymorphic usage in map clauses and target regions (implicit capture)
- Polymorphic dispatch through declare targetting the relevant RTTI bits to device
and then attaching them to the relevant part of the descriptor on device transfer,
allowing dispatch through the descriptor on device to trace to the appropriate device
function. This seems to work sanely from current testing, but may need some alteration
for scenarios that the RTTI ever needs updating on device, this seems unlikely as at least
for the moment it's predomninantly read-only. The upside is that it saves transfer overhead
and maintenance costs for having a non-declare target copy of this RTTI that we transfer
over whenever a polymorphic type is encountered in a map, and subsequently any costs for
amending/resolving the dispatch tables addresses to resolve to the device variants. I
think the main downside is at least for the moment we're forced to declare target ALL
the RTTI, which comes with the downside of the usual initial declare target startup costs.
- Ability to use normal polymorphic intrinsics on the polymorphic types, e.g. extends/is, same
mechanism as above. Except in this scenario we don't need to declare target the dispatch
table just the RTTI.
- Ability to utilise select statements, via same mechanism as above.
- Numerous runtime tests to verify and investigate offload behaviour.
The main mechanism is basically making sure our RTTI which holds the vast majority of polymorphic
class state is on the device. In this case opting for declare target as the mechanism to do so as
the RTTI remains largelly static (in cases it does not, we may have to emit compiler or fortran
runtime level target updates when we trigger these situations occur, I have yet to encounter one
and a lot of the RTTI is read-only by nature) and we benifit from not having to wrangle host vs
device addressing. So, we declare target the basic RTTI for the class/classes, and we do so for
the dispatch table and it's associated functions as well, these then all end up with device
side variants. When we map our host side descriptor wrapping our polymorphic class to device,
alongside the usual base address pointer attachment we must to a RTTI/derived type pointer
attachment, but instead of pointing to a device side copy/clone of the data like we do with
the regular base address, we simply point the RTTI/derived type pointer to the device resident
declare target RTTI information, so there is no transferral outside of whatever is neccessary
on runtime startup. Any queries or dispatch access then route through this.
Another lesser detail, is that we have to amend the bounds information for polymorphic classes
in certain cases to make use of the dynamic size at the time of mapping, so the object doesn't
unintenitonally get segmented or otherwise mismapped.
The implementation and legality of all test cases are up for debate! Main goal is to help
specification discussion on this and start with a reasonable initial implementation.
---
flang/lib/Lower/Bridge.cpp | 18 +
flang/lib/Lower/ConvertVariable.cpp | 21 +-
flang/lib/Lower/OpenMP/Utils.cpp | 8 +
flang/lib/Lower/OpenMP/Utils.h | 8 +
.../Optimizer/OpenMP/MapInfoFinalization.cpp | 255 +++++++++--
flang/lib/Semantics/check-omp-structure.cpp | 108 +++++
flang/lib/Semantics/check-omp-structure.h | 2 +
.../polymorphic-rtti-declare-target.f90 | 58 +++
.../OpenMP/map-types-and-sizes.f90 | 405 +++++++++++++++++-
...allocatable-dtype-intermediate-map-gen.f90 | 2 +-
.../OpenMP/polymorphic-derived-type-map.f90 | 50 +++
...arget-polymorphic-derived-type-version.f90 | 111 +++++
.../omp-map-info-finalization-polymorphic.fir | 43 ++
...rget-implicit-map-polymorphic-dispatch.f90 | 218 ++++++++++
...get-map-polymorphic-abstract-base-rtti.f90 | 84 ++++
...lymorphic-abstract-type-bound-dispatch.f90 | 128 ++++++
.../target-map-polymorphic-array-rtti.f90 | 66 +++
...phic-array-section-type-bound-dispatch.f90 | 160 +++++++
...-polymorphic-array-type-bound-dispatch.f90 | 156 +++++++
.../target-map-polymorphic-derived-type.f90 | 139 ++++++
...morphic-multilevel-type-bound-dispatch.f90 | 156 +++++++
.../target-map-polymorphic-nested-rtti.f90 | 82 ++++
.../target-map-polymorphic-pointer-rtti.f90 | 71 +++
...olymorphic-pointer-type-bound-dispatch.f90 | 138 ++++++
.../target-map-polymorphic-remap-rtti.f90 | 112 +++++
...target-map-polymorphic-rtti-intrinsics.f90 | 112 +++++
.../target-map-polymorphic-same-type-as.f90 | 93 ++++
...et-map-polymorphic-type-bound-dispatch.f90 | 95 ++++
28 files changed, 2851 insertions(+), 48 deletions(-)
create mode 100644 flang/test/Fir/OpenMP/polymorphic-rtti-declare-target.f90
create mode 100644 flang/test/Lower/OpenMP/polymorphic-derived-type-map.f90
create mode 100644 flang/test/Semantics/OpenMP/target-polymorphic-derived-type-version.f90
create mode 100644 flang/test/Transforms/omp-map-info-finalization-polymorphic.fir
create mode 100644 offload/test/offloading/fortran/target-implicit-map-polymorphic-dispatch.f90
create mode 100644 offload/test/offloading/fortran/target-map-polymorphic-abstract-base-rtti.f90
create mode 100644 offload/test/offloading/fortran/target-map-polymorphic-abstract-type-bound-dispatch.f90
create mode 100644 offload/test/offloading/fortran/target-map-polymorphic-array-rtti.f90
create mode 100644 offload/test/offloading/fortran/target-map-polymorphic-array-section-type-bound-dispatch.f90
create mode 100644 offload/test/offloading/fortran/target-map-polymorphic-array-type-bound-dispatch.f90
create mode 100644 offload/test/offloading/fortran/target-map-polymorphic-derived-type.f90
create mode 100644 offload/test/offloading/fortran/target-map-polymorphic-multilevel-type-bound-dispatch.f90
create mode 100644 offload/test/offloading/fortran/target-map-polymorphic-nested-rtti.f90
create mode 100644 offload/test/offloading/fortran/target-map-polymorphic-pointer-rtti.f90
create mode 100644 offload/test/offloading/fortran/target-map-polymorphic-pointer-type-bound-dispatch.f90
create mode 100644 offload/test/offloading/fortran/target-map-polymorphic-remap-rtti.f90
create mode 100644 offload/test/offloading/fortran/target-map-polymorphic-rtti-intrinsics.f90
create mode 100644 offload/test/offloading/fortran/target-map-polymorphic-same-type-as.f90
create mode 100644 offload/test/offloading/fortran/target-map-polymorphic-type-bound-dispatch.f90
diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp
index 9a35b82b8f20ca..eee0c4974ea852 100644
--- a/flang/lib/Lower/Bridge.cpp
+++ b/flang/lib/Lower/Bridge.cpp
@@ -12,6 +12,7 @@
#include "flang/Lower/Bridge.h"
+#include "OpenMP/Utils.h"
#include "flang/Evaluate/tools.h"
#include "flang/Lower/Allocatable.h"
#include "flang/Lower/CUDA.h"
@@ -68,6 +69,8 @@
#include "flang/Support/Flags.h"
#include "flang/Support/Version.h"
#include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h"
+#include "mlir/Dialect/OpenMP/OpenMPInterfaces.h"
+#include "mlir/Dialect/OpenMP/Utils/Utils.h"
#include "mlir/Dialect/SCF/IR/SCF.h"
#include "mlir/IR/BuiltinAttributes.h"
#include "mlir/IR/Matchers.h"
@@ -494,6 +497,21 @@ class TypeInfoConverter {
builder, info.loc,
mlir::StringAttr::get(builder.getContext(), tbpName),
mlir::SymbolRefAttr::get(builder.getContext(), bindingName));
+
+ // Type-bound dispatch tables store procedure addresses in runtime
+ // TypeDescriptor metadata. If the TypeDescriptor is registered for
+ // OpenMP offload, the referenced procedures must also be available in
+ // the device image so device-side dispatch table entries can refer to
+ // device functions.
+ if (converter.getFoldingContext().languageFeatures().IsEnabled(
+ Fortran::common::LanguageFeature::OpenMP) &&
+ mlir::omp::getOpenMPVersionAttribute(converter.getModuleOp(),
+ /*fallback=*/0) >= 61)
+ if (mlir::Operation *bindingOp =
+ builder.getModule().lookupSymbol(bindingName))
+ Fortran::lower::omp::markDeclareTarget(bindingOp,
+ /*implicit=*/true);
+
// Propagate DEFERRED attribute on the binding to fir.dt_entry.
if (binding.get().attrs().test(Fortran::semantics::Attr::DEFERRED))
dtEntry->setAttr(fir::DTEntryOp::getDeferredAttrNameStr(),
diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp
index 553032bb3909e7..557d6140343eac 100644
--- a/flang/lib/Lower/ConvertVariable.cpp
+++ b/flang/lib/Lower/ConvertVariable.cpp
@@ -11,6 +11,7 @@
//===----------------------------------------------------------------------===//
#include "flang/Lower/ConvertVariable.h"
+#include "OpenMP/Utils.h"
#include "flang/Lower/AbstractConverter.h"
#include "flang/Lower/Allocatable.h"
#include "flang/Lower/BoxAnalyzer.h"
@@ -48,6 +49,7 @@
#include "flang/Semantics/type.h"
#include "mlir/Dialect/Complex/IR/Complex.h"
#include "mlir/Dialect/OpenACC/OpenACC.h"
+#include "mlir/Dialect/OpenMP/Utils/Utils.h"
#include "llvm/ADT/APInt.h"
#include "llvm/ADT/SmallVector.h"
#include "llvm/Support/CommandLine.h"
@@ -3377,7 +3379,24 @@ void Fortran::lower::createRuntimeTypeInfoGlobal(
std::string globalName = converter.mangleName(typeInfoSym);
auto var = Fortran::lower::pft::Variable(typeInfoSym, /*global=*/true);
fir::LinkageAttr linkage = getLinkageAttribute(converter, var);
- defineGlobal(converter, var, globalName, linkage);
+ fir::GlobalOp global = defineGlobal(converter, var, globalName, linkage);
+
+ // For OpenMP we make the compiler generated RTTI objects declare-target
+ // globals so that we do not have to transfer the RTTI to device on each map
+ // of a RTTI dependent type and all RTTI remains consistent on device, in
+ // particular the polymorphic function dispatch table, the RTTI and the
+ // dispatch functions are lowered to device and have device consistent
+ // addresses through declare target, and we simply have to then redirect any
+ // mapped polymorphic types descriptor to point at this global type
+ // information to access the device side dispatch table for the type and any
+ // other RTTI that's required for things like SELECT statements, dynamic
+ // variable access and polymorphic intrinsic functions.
+ if (converter.getFoldingContext().languageFeatures().IsEnabled(
+ Fortran::common::LanguageFeature::OpenMP) &&
+ mlir::omp::getOpenMPVersionAttribute(converter.getModuleOp(),
+ /*fallback=*/0) >= 61)
+ Fortran::lower::omp::markDeclareTarget(global.getOperation(),
+ /*implicit=*/false);
}
mlir::Type Fortran::lower::getCrayPointeeBoxType(mlir::Type fortranType) {
diff --git a/flang/lib/Lower/OpenMP/Utils.cpp b/flang/lib/Lower/OpenMP/Utils.cpp
index e05a3eab6fad6d..87d75336e69a96 100644
--- a/flang/lib/Lower/OpenMP/Utils.cpp
+++ b/flang/lib/Lower/OpenMP/Utils.cpp
@@ -172,6 +172,14 @@ void gatherFuncAndVarSyms(
symbolAndClause.emplace_back(clause, *object.sym(), automap);
}
+void markDeclareTarget(mlir::Operation *op, bool implicit) {
+ if (auto declareTargetOp =
+ llvm::dyn_cast<mlir::omp::DeclareTargetInterface>(op))
+ declareTargetOp.setDeclareTarget(mlir::omp::DeclareTargetDeviceType::any,
+ mlir::omp::DeclareTargetCaptureClause::to,
+ /*automap=*/false, implicit);
+}
+
// This function gathers the individual omp::Object's that make up a
// larger omp::Object symbol.
//
diff --git a/flang/lib/Lower/OpenMP/Utils.h b/flang/lib/Lower/OpenMP/Utils.h
index 4560c9df349b2d..70439877bc1786 100644
--- a/flang/lib/Lower/OpenMP/Utils.h
+++ b/flang/lib/Lower/OpenMP/Utils.h
@@ -22,6 +22,10 @@
extern llvm::cl::opt<bool> treatIndexAsSection;
+namespace mlir {
+class Operation;
+} // namespace mlir
+
namespace fir {
class FirOpBuilder;
class RecordType;
@@ -162,6 +166,10 @@ void gatherFuncAndVarSyms(
llvm::SmallVectorImpl<DeclareTargetCaptureInfo> &symbolAndClause,
bool automap = false);
+/// If \p op implements the OpenMP DeclareTargetInterface, mark it as declare
+/// target with device_type=any, capture=to, automap=false. No-op otherwise.
+void markDeclareTarget(mlir::Operation *op, bool implicit);
+
int64_t getCollapseValue(const List<Clause> &clauses);
void genObjectList(const ObjectList &objects,
diff --git a/flang/lib/Optimizer/OpenMP/MapInfoFinalization.cpp b/flang/lib/Optimizer/OpenMP/MapInfoFinalization.cpp
index 8046a702f330a7..efdd7a10986b19 100644
--- a/flang/lib/Optimizer/OpenMP/MapInfoFinalization.cpp
+++ b/flang/lib/Optimizer/OpenMP/MapInfoFinalization.cpp
@@ -33,8 +33,10 @@
#include "flang/Optimizer/HLFIR/HLFIROps.h"
#include "flang/Optimizer/OpenMP/Passes.h"
#include "mlir/Analysis/SliceAnalysis.h"
+#include "mlir/Dialect/Arith/IR/Arith.h"
#include "mlir/Dialect/Func/IR/FuncOps.h"
#include "mlir/Dialect/OpenMP/OpenMPDialect.h"
+#include "mlir/Dialect/OpenMP/Utils/Utils.h"
#include "mlir/IR/BuiltinOps.h"
#include "mlir/IR/Operation.h"
#include "mlir/IR/SymbolTable.h"
@@ -548,6 +550,93 @@ class MapInfoFinalizationPass
return mapType;
}
+ static bool shouldMapDescriptorTypeDesc(mlir::Value descriptor,
+ bool supportsPolymorphicMap) {
+ if (!supportsPolymorphicMap)
+ return false;
+ auto boxTy = mlir::dyn_cast<fir::BaseBoxType>(
+ fir::unwrapRefType(descriptor.getType()));
+ return boxTy && fir::isPolymorphicType(boxTy) && fir::boxHasAddendum(boxTy);
+ }
+
+ static bool shouldMapPolymorphicDescriptorWithRuntimeElementSize(
+ mlir::Value descriptor, bool supportsPolymorphicMap) {
+ if (!supportsPolymorphicMap)
+ return false;
+ auto boxTy = mlir::dyn_cast<fir::BaseBoxType>(
+ fir::unwrapRefType(descriptor.getType()));
+ return boxTy && fir::isPolymorphicType(boxTy);
+ }
+
+ mlir::Value getAsIndex(mlir::Location loc, mlir::Value value,
+ fir::FirOpBuilder &builder) {
+ if (value.getType() == builder.getIndexType())
+ return value;
+ return builder.createConvert(loc, builder.getIndexType(), value);
+ }
+
+ /// For polymorphic boxes, we currently need to readjust the bounds to
+ /// use the descriptor's elem_len as the dynamic type may extend the
+ /// declared type on the map at runtime. So we turn the bounds calculation
+ /// into a 1-D byte mapping so polymorphic objects and arrays are sized by
+ /// the runtime element length.
+ ///
+ /// This could in theory be incorporated into the earlier lowering stage,
+ /// but there's a number of areas in the lowering that require bounds
+ /// adjustments and a number of passes that themselves generate maps that
+ /// may depend on this regeneration, so this is for the moment the most
+ /// consistent place for re-adjustment of these cases, and generally we
+ /// adjust a lot of the descriptor / data relationship here as we expand
+ /// into multiple maps.
+ llvm::SmallVector<mlir::Value>
+ genRuntimeSizedBaseAddrBounds(mlir::Location loc, mlir::Value descriptor,
+ mlir::ValueRange existingBounds,
+ fir::FirOpBuilder &builder) {
+ mlir::Type idxTy = builder.getIndexType();
+ mlir::Value zero = builder.createIntegerConstant(loc, idxTy, 0);
+ mlir::Value one = builder.createIntegerConstant(loc, idxTy, 1);
+ mlir::Value box = descriptor;
+ if (fir::isa_ref_type(box.getType()))
+ box = fir::LoadOp::create(builder, loc, box);
+ mlir::Value elemSize = fir::BoxEleSizeOp::create(builder, loc, idxTy, box);
+
+ mlir::Value elemCount = one;
+ mlir::Value elemOffset = zero;
+ for (mlir::Value bound : llvm::reverse(existingBounds)) {
+ auto boundOp = mlir::dyn_cast_if_present<mlir::omp::MapBoundsOp>(
+ bound.getDefiningOp());
+ if (!boundOp)
+ continue;
+ mlir::Value lowerBound =
+ getAsIndex(loc, boundOp.getLowerBound(), builder);
+ mlir::Value upperBound =
+ getAsIndex(loc, boundOp.getUpperBound(), builder);
+ mlir::Value extent = getAsIndex(loc, boundOp.getExtent(), builder);
+ mlir::Value boundElemCount = mlir::arith::AddIOp::create(
+ builder, loc,
+ mlir::arith::SubIOp::create(builder, loc, upperBound, lowerBound),
+ one);
+ elemCount =
+ mlir::arith::MulIOp::create(builder, loc, elemCount, boundElemCount);
+ elemOffset = mlir::arith::AddIOp::create(
+ builder, loc,
+ mlir::arith::MulIOp::create(builder, loc, elemOffset, extent),
+ lowerBound);
+ }
+
+ mlir::Value byteOffset =
+ mlir::arith::MulIOp::create(builder, loc, elemOffset, elemSize);
+ mlir::Value byteExtent =
+ mlir::arith::MulIOp::create(builder, loc, elemCount, elemSize);
+ mlir::Value upperBound = mlir::arith::SubIOp::create(
+ builder, loc,
+ mlir::arith::AddIOp::create(builder, loc, byteOffset, byteExtent), one);
+ mlir::Type mapBoundsTy = builder.getType<mlir::omp::MapBoundsType>();
+ return {mlir::omp::MapBoundsOp::create(
+ builder, loc, mapBoundsTy, byteOffset, upperBound, byteExtent, one,
+ /*strideInBytes=*/true, zero)};
+ }
+
/// Function that generates a FIR operation accessing the descriptor's
/// base address (BoxOffsetOp) and a MapInfoOp for it. The most
/// important thing to note is that we normally move the bounds from
@@ -557,11 +646,14 @@ class MapInfoFinalizationPass
/// descriptor map before this pass splits it). Lowering attaches a NameLoc
/// there for the Fortran map text. This is used with new Ops being
/// created by this function.
+ /// \p parentOp is the MapInfoOp being expanded (the descriptor map before
+ /// this pass splits it). Lowering attaches a NameLoc there for the Fortran
+ /// map text. New ops created here use its location so NameLoc is preserved.
mlir::omp::MapInfoOp
genBaseAddrMap(mlir::Location mapInfoOpLoc, mlir::Value descriptor,
mlir::omp::MapInfoOp parentOp,
mlir::omp::ClauseMapFlags mapType, fir::FirOpBuilder &builder,
- bool isRefPtee = false,
+ bool supportsPolymorphicMap, bool isRefPtee = false,
mlir::FlatSymbolRefAttr mapperId = mlir::FlatSymbolRefAttr()) {
mlir::Value baseAddr = fir::BoxOffsetOp::create(
builder, mapInfoOpLoc, descriptor, fir::BoxFieldAttr::base_addr);
@@ -577,6 +669,15 @@ class MapInfoFinalizationPass
mlir::Type underlyingDescType = fir::unwrapRefType(descriptor.getType());
+ llvm::SmallVector<mlir::Value> bounds(parentOp.getBounds().begin(),
+ parentOp.getBounds().end());
+ if (shouldMapPolymorphicDescriptorWithRuntimeElementSize(
+ descriptor, supportsPolymorphicMap)) {
+ bounds = genRuntimeSizedBaseAddrBounds(mapInfoOpLoc, descriptor,
+ parentOp.getBounds(), builder);
+ underlyingBaseAddrType = builder.getI8Type();
+ }
+
// Member of the descriptor pointing at the allocated data
return mlir::omp::MapInfoOp::create(
builder, mapInfoOpLoc, baseAddr.getType(), descriptor,
@@ -587,8 +688,7 @@ class MapInfoFinalizationPass
mlir::omp::VariableCaptureKind::ByRef),
baseAddr, mlir::TypeAttr::get(underlyingBaseAddrType),
isRefPtee ? parentOp.getMembers() : mlir::SmallVector<mlir::Value>{},
- isRefPtee ? parentOp.getMembersIndexAttr() : mlir::ArrayAttr{},
- parentOp.getBounds(),
+ isRefPtee ? parentOp.getMembersIndexAttr() : mlir::ArrayAttr{}, bounds,
/*mapperId=*/mapperId,
/*name=*/builder.getStringAttr(""),
/*partial_map=*/builder.getBoolAttr(false));
@@ -986,6 +1086,35 @@ class MapInfoFinalizationPass
return baseAddrType;
}
+ mlir::Operation *genImplicitPointerAttachMap(
+ mlir::omp::MapInfoOp descMapOp, mlir::Value attachBase,
+ mlir::Type attachBaseType, mlir::Value pointerSlotAddr,
+ mlir::Type pointerSlotPointeeType, mlir::ValueRange bounds,
+ llvm::SmallVectorImpl<ParentAndPlacement> &mapMemberUsers,
+ mlir::Operation *target, fir::FirOpBuilder &builder,
+ mlir::omp::ClauseMapFlags refFlagType, mlir::Type resultType,
+ bool isAttachAlways = false) {
+ auto implicitAttachMap = mlir::omp::MapInfoOp::create(
+ builder, descMapOp->getLoc(), resultType, attachBase,
+ mlir::TypeAttr::get(attachBaseType),
+ builder.getAttr<mlir::omp::ClauseMapFlagsAttr>(
+ mlir::omp::ClauseMapFlags::attach | refFlagType |
+ (isAttachAlways ? mlir::omp::ClauseMapFlags::always
+ : mlir::omp::ClauseMapFlags::none)),
+ descMapOp.getMapCaptureTypeAttr(), /*varPtrPtr=*/
+ pointerSlotAddr, mlir::TypeAttr::get(pointerSlotPointeeType),
+ /*members=*/mlir::SmallVector<mlir::Value>{},
+ /*membersIndex=*/mlir::ArrayAttr{}, bounds,
+ /*mapperId*/ mlir::FlatSymbolRefAttr(), descMapOp.getNameAttr(),
+ /*partial_map=*/builder.getBoolAttr(false));
+
+ // Has to be added to the target immediately, as we expect all maps
+ // processed by this pass to have a user that is a target.
+ addAttachMemberToTarget(descMapOp, implicitAttachMap, mapMemberUsers,
+ builder, target);
+ return implicitAttachMap;
+ }
+
/// This function generates an attach map, which is an type of OpenMP map that
/// binds a pointer to its data. In the case of Fortran, this binding is
/// primarily for binding the pointer inside of descriptors to the underlying
@@ -1001,7 +1130,8 @@ class MapInfoFinalizationPass
llvm::SmallVectorImpl<ParentAndPlacement> &mapMemberUsers,
mlir::Operation *target, fir::FirOpBuilder &builder,
mlir::omp::ClauseMapFlags refFlagType, bool isAttachAlways = false,
- mlir::Value reuseBaseAddr = mlir::Value{}) {
+ mlir::Value reuseBaseAddr = mlir::Value{},
+ bool supportsPolymorphicMap = false) {
auto baseAddr =
reuseBaseAddr
? reuseBaseAddr
@@ -1009,28 +1139,44 @@ class MapInfoFinalizationPass
fir::BoxFieldAttr::base_addr);
mlir::Type underlyingVarType = getUnderlyingVarType(baseAddr.getType());
+ llvm::SmallVector<mlir::Value> bounds(descMapOp.getBounds().begin(),
+ descMapOp.getBounds().end());
+ if (shouldMapPolymorphicDescriptorWithRuntimeElementSize(
+ descriptor, supportsPolymorphicMap)) {
+ bounds = genRuntimeSizedBaseAddrBounds(descMapOp->getLoc(), descriptor,
+ descMapOp.getBounds(), builder);
+ underlyingVarType = builder.getI8Type();
+ }
+ mlir::Type runtimePtrType = fir::unwrapRefType(descriptor.getType());
- auto implicitAttachMap = mlir::omp::MapInfoOp::create(
- builder, descMapOp->getLoc(), descMapOp.getResult().getType(),
- descriptor,
- mlir::TypeAttr::get(fir::unwrapRefType(descriptor.getType())),
- builder.getAttr<mlir::omp::ClauseMapFlagsAttr>(
- mlir::omp::ClauseMapFlags::attach | refFlagType |
- (isAttachAlways ? mlir::omp::ClauseMapFlags::always
- : mlir::omp::ClauseMapFlags::none)),
- descMapOp.getMapCaptureTypeAttr(), /*varPtrPtr=*/
- baseAddr, mlir::TypeAttr::get(underlyingVarType),
- /*members=*/mlir::SmallVector<mlir::Value>{},
- /*membersIndex=*/mlir::ArrayAttr{},
- /*bounds=*/descMapOp.getBounds(),
- /*mapperId*/ mlir::FlatSymbolRefAttr(), descMapOp.getNameAttr(),
- /*partial_map=*/builder.getBoolAttr(false));
+ return genImplicitPointerAttachMap(
+ descMapOp, descriptor, runtimePtrType, baseAddr, underlyingVarType,
+ bounds, mapMemberUsers, target, builder, refFlagType,
+ descMapOp.getResult().getType(), isAttachAlways);
+ }
- // Has to be added to the target immediately, as we expect all maps
- // processed by this pass to have a user that is a target.
- addAttachMemberToTarget(descMapOp, implicitAttachMap, mapMemberUsers,
- builder, target);
- return implicitAttachMap;
+ [[maybe_unused]] mlir::Operation *genImplicitTypeDescAttachMap(
+ mlir::omp::MapInfoOp descMapOp, mlir::Value descriptor,
+ llvm::SmallVectorImpl<ParentAndPlacement> &mapMemberUsers,
+ mlir::Operation *target, fir::FirOpBuilder &builder,
+ mlir::omp::ClauseMapFlags refFlagType, bool isAttachAlways = false) {
+ auto typeDescFieldAddr =
+ fir::BoxOffsetOp::create(builder, descMapOp->getLoc(), descriptor,
+ fir::BoxFieldAttr::derived_type);
+
+ // This attach entry binds the device copy of the dynamic type descriptor to
+ // the descriptor addendum's derived_type pointer slot. The var_ptr must
+ // therefore be the address of that pointer slot in the originating
+ // descriptor, not the descriptor base address. Model both var_ptr and
+ // var_ptr_ptr as pointer-sized objects for this attach map so lowering
+ // produces an 8-byte pointer attach entry.
+ mlir::Type runtimePtrType =
+ fir::LLVMPointerType::get(builder.getContext(), builder.getI8Type());
+
+ return genImplicitPointerAttachMap(
+ descMapOp, typeDescFieldAddr, runtimePtrType, typeDescFieldAddr,
+ runtimePtrType, mlir::ValueRange{}, mapMemberUsers, target, builder,
+ refFlagType, typeDescFieldAddr.getType(), isAttachAlways);
}
// If the operation that we are expanding with a descriptor has a user
@@ -1103,7 +1249,8 @@ class MapInfoFinalizationPass
genRefPtrMap(mlir::omp::MapInfoOp op, fir::FirOpBuilder &builder,
mlir::Operation *target, mlir::Value descriptor,
llvm::SmallVectorImpl<ParentAndPlacement> &mapMemberUsers,
- bool isAttachNever, bool isAttachAlways) {
+ bool isAttachNever, bool isAttachAlways,
+ bool supportsPolymorphicMap) {
auto newMapInfoOp = mlir::omp::MapInfoOp::create(
builder, op->getLoc(), op.getResult().getType(), descriptor,
mlir::TypeAttr::get(fir::unwrapRefType(descriptor.getType())),
@@ -1117,7 +1264,15 @@ class MapInfoFinalizationPass
if (!isAttachNever)
genImplicitAttachMap(op, descriptor, mapMemberUsers, target, builder,
- mlir::omp::ClauseMapFlags::ref_ptr, isAttachAlways);
+ mlir::omp::ClauseMapFlags::ref_ptr, isAttachAlways,
+ /*reuseBaseAddr=*/mlir::Value{},
+ supportsPolymorphicMap);
+
+ if (shouldMapDescriptorTypeDesc(descriptor, supportsPolymorphicMap))
+ genImplicitTypeDescAttachMap(op, descriptor, mapMemberUsers, target,
+ builder, mlir::omp::ClauseMapFlags::ref_ptr,
+ isAttachAlways);
+
op.replaceAllUsesWith(newMapInfoOp.getResult());
op->erase();
return newMapInfoOp;
@@ -1137,7 +1292,7 @@ class MapInfoFinalizationPass
mlir::Operation *target, mlir::Value descriptor,
llvm::SmallVectorImpl<ParentAndPlacement> &mapMemberUsers,
bool isAttachNever, bool isAttachAlways,
- mlir::FlatSymbolRefAttr mapperId) {
+ mlir::FlatSymbolRefAttr mapperId, bool supportsPolymorphicMap) {
// NOTE: We replace the descriptor map with the base address map. This
// effectively replaces the descriptor's index position in any complex
// structure mapping. This is a little different to the
@@ -1147,12 +1302,12 @@ class MapInfoFinalizationPass
// issues do pop up.
auto newMapInfoOp =
genBaseAddrMap(op.getLoc(), descriptor, op, op.getMapType(), builder,
- /*IsRefPtee=*/true, mapperId);
+ supportsPolymorphicMap, /*IsRefPtee=*/true, mapperId);
if (!isAttachNever)
genImplicitAttachMap(op, descriptor, mapMemberUsers, target, builder,
mlir::omp::ClauseMapFlags::ref_ptee, isAttachAlways,
- newMapInfoOp.getVarPtrPtr());
+ newMapInfoOp.getVarPtrPtr(), supportsPolymorphicMap);
op.replaceAllUsesWith(newMapInfoOp.getResult());
op->erase();
return newMapInfoOp;
@@ -1172,7 +1327,7 @@ class MapInfoFinalizationPass
llvm::SmallVectorImpl<ParentAndPlacement> &mapMemberUsers,
bool isAttachNever, bool isAttachAlways, bool mapOnlyDescriptor,
bool descCanBeDeferred, bool canOptimizeDescViaPrivatization,
- mlir::FlatSymbolRefAttr mapperId) {
+ mlir::FlatSymbolRefAttr mapperId, bool supportsPolymorphicMap) {
bool isRefPtrPtee =
bitEnumContainsAll(op.getMapType(),
mlir::omp::ClauseMapFlags::ref_ptr) &&
@@ -1194,7 +1349,7 @@ class MapInfoFinalizationPass
if (!mapOnlyDescriptor) {
baseAddr =
genBaseAddrMap(op.getLoc(), descriptor, op, op.getMapType(), builder,
- /*IsRefPtee=*/false, mapperId);
+ supportsPolymorphicMap, /*IsRefPtee=*/false, mapperId);
createBaseAddrInsertion(builder, op, baseAddr, mapMemberUsers,
newMembersAttr, newMembers, memberIndices);
}
@@ -1229,13 +1384,20 @@ class MapInfoFinalizationPass
mlir::Operation *attachMap = nullptr;
if (!isAttachNever && !mapOnlyDescriptor) {
- attachMap =
- genImplicitAttachMap(op, descriptor, mapMemberUsers, target, builder,
- mlir::omp::ClauseMapFlags::ref_ptr |
- mlir::omp::ClauseMapFlags::ref_ptee,
- isAttachAlways, baseAddr.getVarPtrPtr());
+ attachMap = genImplicitAttachMap(
+ op, descriptor, mapMemberUsers, target, builder,
+ mlir::omp::ClauseMapFlags::ref_ptr |
+ mlir::omp::ClauseMapFlags::ref_ptee,
+ isAttachAlways, baseAddr.getVarPtrPtr(), supportsPolymorphicMap);
}
+ if (shouldMapDescriptorTypeDesc(descriptor, supportsPolymorphicMap))
+ genImplicitTypeDescAttachMap(op, descriptor, mapMemberUsers, target,
+ builder,
+ mlir::omp::ClauseMapFlags::ref_ptr |
+ mlir::omp::ClauseMapFlags::ref_ptee,
+ isAttachAlways);
+
op.replaceAllUsesWith(newMapInfoOp.getResult());
op->erase();
@@ -1355,7 +1517,8 @@ class MapInfoFinalizationPass
mlir::omp::MapInfoOp genDescriptorMaps(mlir::omp::MapInfoOp op,
fir::FirOpBuilder &builder,
mlir::Operation *target,
- bool &canOptimizeUseDeviceAddr) {
+ bool &canOptimizeUseDeviceAddr,
+ bool supportsPolymorphicMap) {
bool descCanBeDeferred = false;
bool canOptimizeDescViaPrivatization = false;
llvm::SmallVector<ParentAndPlacement> mapMemberUsers;
@@ -1409,17 +1572,18 @@ class MapInfoFinalizationPass
// case where we do a similar style of mapping for deeper nestings.
mlir::omp::MapInfoOp newMapInfo;
if (isRefPtr && op.getMembers().empty()) {
- newMapInfo = genRefPtrMap(op, builder, target, descriptor, mapMemberUsers,
- isAttachNever, isAttachAlways);
- } else if (isRefPtee) {
newMapInfo =
- genRefPteeMap(op, builder, target, descriptor, mapMemberUsers,
- isAttachNever, isAttachAlways, mapperId);
+ genRefPtrMap(op, builder, target, descriptor, mapMemberUsers,
+ isAttachNever, isAttachAlways, supportsPolymorphicMap);
+ } else if (isRefPtee) {
+ newMapInfo = genRefPteeMap(op, builder, target, descriptor,
+ mapMemberUsers, isAttachNever, isAttachAlways,
+ mapperId, supportsPolymorphicMap);
} else {
newMapInfo = genRefPtrPteeOrDefaultMap(
op, builder, target, descriptor, mapMemberUsers, isAttachNever,
isAttachAlways, mapOnlyDescriptor, descCanBeDeferred,
- canOptimizeDescViaPrivatization, mapperId);
+ canOptimizeDescViaPrivatization, mapperId, supportsPolymorphicMap);
}
return newMapInfo;
}
@@ -1725,6 +1889,8 @@ class MapInfoFinalizationPass
// will mutate siblings of MapInfoOp.
void runOnOperation() override {
mlir::ModuleOp module = mlir::cast<mlir::ModuleOp>(getOperation());
+ bool supportsPolymorphicMap =
+ mlir::omp::getOpenMPVersionAttribute(module, /*fallback=*/0) >= 61;
fir::KindMapping kindMap = fir::getKindMapping(module);
fir::FirOpBuilder builder{module, std::move(kindMap)};
@@ -1783,7 +1949,8 @@ class MapInfoFinalizationPass
llvm::dyn_cast<mlir::omp::TargetDataOp>(*targetUser);
bool canOptimizeUseDeviceAddr = false;
mlir::omp::MapInfoOp newMapInfo = genDescriptorMaps(
- op, builder, targetUser, canOptimizeUseDeviceAddr);
+ op, builder, targetUser, canOptimizeUseDeviceAddr,
+ supportsPolymorphicMap);
if (canOptimizeUseDeviceAddr && targetDataOp) {
genOptimizedUseDeviceAddr(builder, targetDataOp, newMapInfo,
module);
diff --git a/flang/lib/Semantics/check-omp-structure.cpp b/flang/lib/Semantics/check-omp-structure.cpp
index 3880128545f5ea..e18571d6981a5e 100644
--- a/flang/lib/Semantics/check-omp-structure.cpp
+++ b/flang/lib/Semantics/check-omp-structure.cpp
@@ -145,6 +145,15 @@ static const Symbol *GetBaseObjectSymbol(const parser::OmpObject &object) {
return nullptr;
}
+static bool IsPolymorphicType(const Symbol &symbol) {
+ if (std::optional<evaluate::DynamicType> type{
+ evaluate::DynamicType::From(symbol.GetUltimate())}) {
+ return type->IsPolymorphic() &&
+ (type->IsUnlimitedPolymorphic() || evaluate::GetDerivedTypeSpec(*type));
+ }
+ return false;
+}
+
static bool HasCloseMapModifier(const parser::OmpMapClause &clause) {
const auto &modifiers{OmpGetModifiers(clause)};
if (OmpGetUniqueModifier<parser::OmpCloseModifier>(modifiers)) {
@@ -803,6 +812,96 @@ bool OmpStructureChecker::InTargetRegion() {
return false;
}
+void OmpStructureChecker::CheckPolymorphicMapObjects(
+ const parser::OmpObjectList &objects) {
+ if (context_.langOptions().getOpenMPVersion() >= 61)
+ return;
+
+ llvm::SmallPtrSet<const Symbol *, 8> diagnosed;
+ for (const parser::OmpObject &object : objects.v) {
+ llvm::SmallVector<const Symbol *, 2> candidates;
+ if (const Symbol * symbol{GetObjectSymbol(object, /*ultimate=*/true)})
+ candidates.push_back(symbol);
+ if (const Symbol * symbol{GetBaseObjectSymbol(object)})
+ candidates.push_back(symbol);
+
+ for (const Symbol *symbol : candidates) {
+ const Symbol &ultimate{symbol->GetUltimate()};
+ if (!diagnosed.insert(&ultimate).second || !IsPolymorphicType(ultimate))
+ continue;
+
+ context_.Say(GetObjectSource(object).value_or(GetContext().clauseSource),
+ "Polymorphic type '%s' may not appear in a MAP clause on a target offload construct before OpenMP 6.1"_err_en_US,
+ ultimate.name());
+ }
+ }
+}
+
+namespace {
+class TargetPolymorphicUseChecker {
+public:
+ explicit TargetPolymorphicUseChecker(SemanticsContext &context)
+ : context_{context} {}
+
+ template <typename T> bool Pre(const T &) { return true; }
+ template <typename T> void Post(const T &) {}
+
+ bool Pre(const parser::Designator &designator) {
+ common::visit(common::visitors{
+ [&](const parser::DataRef &dataRef) {
+ Diagnose(GetBaseName(dataRef), designator.source);
+ },
+ [&](const parser::Substring &substring) {
+ Diagnose(
+ GetBaseName(std::get<parser::DataRef>(substring.t)),
+ designator.source);
+ },
+ },
+ designator.u);
+ return true;
+ }
+
+ bool Pre(const parser::Expr &expr) {
+ if (const auto *semExpr{GetExpr(context_, expr)}) {
+ for (const Symbol &symbol : evaluate::CollectSymbols(*semExpr)) {
+ Diagnose(&GetAssociationRoot(symbol).GetUltimate(), expr.source);
+ }
+ }
+ return true;
+ }
+
+private:
+ void Diagnose(const parser::Name *name, parser::CharBlock source) {
+ if (name && name->symbol)
+ Diagnose(&name->symbol->GetUltimate(), source);
+ }
+
+ void Diagnose(const Symbol *symbol, parser::CharBlock source) {
+ if (!symbol)
+ return;
+ const Symbol &ultimate{symbol->GetUltimate()};
+ if (!diagnosed_.insert(&ultimate).second || !IsPolymorphicType(ultimate))
+ return;
+
+ context_.Say(source,
+ "Polymorphic type '%s' may not be used in a target region before OpenMP 6.1"_err_en_US,
+ ultimate.name());
+ }
+
+ SemanticsContext &context_;
+ llvm::SmallPtrSet<const Symbol *, 8> diagnosed_;
+};
+} // namespace
+
+void OmpStructureChecker::CheckPolymorphicSymbolsInTargetBlock(
+ const parser::Block &block) {
+ if (context_.langOptions().getOpenMPVersion() >= 61)
+ return;
+
+ TargetPolymorphicUseChecker checker{context_};
+ parser::Walk(block, checker);
+}
+
bool OmpStructureChecker::HasRequires(llvm::omp::Clause req) {
const Scope &unit{GetProgramUnit(*scopeStack_.back())};
return common::visit(
@@ -1714,6 +1813,7 @@ void OmpStructureChecker::Enter(const parser::OmpBlockConstruct &x) {
switch (beginSpec.DirId()) {
case llvm::omp::Directive::OMPD_target:
+ CheckPolymorphicSymbolsInTargetBlock(block);
if (CheckTargetBlockOnlyTeams(block)) {
EnterDirectiveNest(TargetBlockOnlyTeams);
}
@@ -5018,6 +5118,14 @@ void OmpStructureChecker::Enter(const parser::OmpClause::Map &x) {
}
}
+ if (version < 61 &&
+ (llvm::is_contained(leafs, Directive::OMPD_target) ||
+ llvm::is_contained(leafs, Directive::OMPD_target_data) ||
+ llvm::is_contained(leafs, Directive::OMPD_target_enter_data) ||
+ llvm::is_contained(leafs, Directive::OMPD_target_exit_data))) {
+ CheckPolymorphicMapObjects(objects);
+ }
+
if (auto *attach{
OmpGetUniqueModifier<parser::OmpAttachModifier>(modifiers)}) {
bool mapEnteringConstructOrMapper{
diff --git a/flang/lib/Semantics/check-omp-structure.h b/flang/lib/Semantics/check-omp-structure.h
index a77506e3299349..cf0b07d1f95e09 100644
--- a/flang/lib/Semantics/check-omp-structure.h
+++ b/flang/lib/Semantics/check-omp-structure.h
@@ -420,6 +420,8 @@ class OmpStructureChecker : public OmpStructureCheckerBase {
void CheckAllowedMapTypes(
parser::OmpMapType::Value, llvm::ArrayRef<parser::OmpMapType::Value>);
void CheckCloseModifierOnMapMembers();
+ void CheckPolymorphicMapObjects(const parser::OmpObjectList &objects);
+ void CheckPolymorphicSymbolsInTargetBlock(const parser::Block &block);
llvm::StringRef getClauseName(llvm::omp::Clause clause) override;
llvm::StringRef getDirectiveName(llvm::omp::Directive directive) override;
diff --git a/flang/test/Fir/OpenMP/polymorphic-rtti-declare-target.f90 b/flang/test/Fir/OpenMP/polymorphic-rtti-declare-target.f90
new file mode 100644
index 00000000000000..75228aa38ee864
--- /dev/null
+++ b/flang/test/Fir/OpenMP/polymorphic-rtti-declare-target.f90
@@ -0,0 +1,58 @@
+! RUN: bbc -emit-hlfir -fopenmp -fopenmp-version=61 %s -o - | fir-opt --fir-polymorphic-op | FileCheck %s
+
+! Verify that OpenMP 6.1 polymorphic offload lowering makes runtime type
+! descriptors and type-bound dispatch targets available to the device, and maps
+! the dynamic type descriptor pointer from the descriptor addendum.
+
+module poly_rtti_declare_target
+ type :: base_t
+ integer :: x
+ contains
+ procedure :: set_x
+ end type
+
+ type, extends(base_t) :: child_t
+ integer :: y
+ contains
+ procedure :: set_x => child_set_x
+ end type
+
+contains
+ subroutine set_x(this)
+ class(base_t), intent(inout) :: this
+ this%x = 1
+ end subroutine
+
+ subroutine child_set_x(this)
+ class(child_t), intent(inout) :: this
+ this%x = 2
+ this%y = 3
+ end subroutine
+
+ subroutine run()
+ class(base_t), allocatable :: obj
+
+ allocate(child_t :: obj)
+
+ !$omp target map(tofrom: obj)
+ call obj%set_x()
+ !$omp end target
+ end subroutine
+end module
+
+! CHECK-LABEL: func.func @_QMpoly_rtti_declare_targetPset_x(
+! CHECK-SAME: attributes {omp.declare_target = #omp.declaretarget<device_type = any, capture_clause = to, implicit = true>}
+
+! CHECK-LABEL: func.func @_QMpoly_rtti_declare_targetPchild_set_x(
+! CHECK-SAME: attributes {omp.declare_target = #omp.declaretarget<device_type = any, capture_clause = to, implicit = true>}
+
+! CHECK: %[[BASE_ADDR:.*]] = fir.box_offset %{{.*}} base_addr
+! CHECK: %[[BASE_MAP:.*]] = omp.map.info {{.*}}var_ptr_ptr(%[[BASE_ADDR]]{{.*}})
+! CHECK: %[[DESC_MAP:.*]] = omp.map.info {{.*}}members(%[[BASE_MAP]] : {{\[}}0{{\]}}
+! CHECK: %[[BASE_ATTACH:.*]] = omp.map.info var_ptr({{.*}}) {{.*}}map_clauses(attach, ref_ptr, ref_ptee){{.*}}var_ptr_ptr(%[[BASE_ADDR]]
+! CHECK: %[[TYPE_DESC:.*]] = fir.box_offset %{{.*}} derived_type
+! CHECK: %[[TYPE_DESC_ATTACH:.*]] = omp.map.info var_ptr(%[[TYPE_DESC]]{{.*}}!fir.llvm_ptr<i8>) {{.*}}map_clauses(attach, ref_ptr, ref_ptee){{.*}}var_ptr_ptr(%[[TYPE_DESC]]{{.*}}!fir.llvm_ptr<i8>)
+! CHECK: omp.target {{.*}}map_entries(%[[DESC_MAP]] -> %{{.*}}, %[[BASE_ATTACH]] -> %{{.*}}, %[[TYPE_DESC_ATTACH]] -> %{{.*}}, %[[BASE_MAP]] -> %{{.*}}
+
+! CHECK: fir.global linkonce_odr @_QMpoly_rtti_declare_targetE.dt.base_t {omp.declare_target = #omp.declaretarget<device_type = any, capture_clause = to>} constant target
+! CHECK: fir.global linkonce_odr @_QMpoly_rtti_declare_targetE.dt.child_t {omp.declare_target = #omp.declaretarget<device_type = any, capture_clause = to>} constant target
diff --git a/flang/test/Integration/OpenMP/map-types-and-sizes.f90 b/flang/test/Integration/OpenMP/map-types-and-sizes.f90
index 1a86c7186a1f5b..b23291f3b6a56e 100644
--- a/flang/test/Integration/OpenMP/map-types-and-sizes.f90
+++ b/flang/test/Integration/OpenMP/map-types-and-sizes.f90
@@ -6,8 +6,8 @@
! added to this directory and sub-directories.
!===----------------------------------------------------------------------===!
-!RUN: %flang_fc1 -emit-llvm -fopenmp -mmlir --enable-delayed-privatization-staging=false -fopenmp-version=51 -fopenmp-targets=amdgcn-amd-amdhsa %s -o - | FileCheck %s --check-prefixes=CHECK,CHECK-NO-FPRIV
-!RUN: %flang_fc1 -emit-llvm -fopenmp -mmlir --enable-delayed-privatization-staging=true -fopenmp-version=51 -fopenmp-targets=amdgcn-amd-amdhsa %s -o - | FileCheck %s --check-prefixes=CHECK,CHECK-FPRIV
+!RUN: %flang_fc1 -emit-llvm -fopenmp -mmlir --enable-delayed-privatization-staging=false -fopenmp-version=61 -fopenmp-targets=amdgcn-amd-amdhsa %s -o - | FileCheck %s --check-prefixes=CHECK,CHECK-NO-FPRIV
+!RUN: %flang_fc1 -emit-llvm -fopenmp -mmlir --enable-delayed-privatization-staging=true -fopenmp-version=61 -fopenmp-targets=amdgcn-amd-amdhsa %s -o - | FileCheck %s --check-prefixes=CHECK,CHECK-FPRIV
!===============================================================================
@@ -429,6 +429,87 @@ subroutine mapType_common_block_members
!$omp end target
end subroutine mapType_common_block_members
+!CHECK: @.offload_sizes{{.*}} = private unnamed_addr constant [7 x i64] [i64 0, i64 40, i64 0, i64 4, i64 0, i64 0, i64 0]
+!CHECK: @.offload_maptypes{{.*}} = private unnamed_addr constant [7 x i64] [i64 33, i64 281474976710661, i64 3, i64 35, i64 16384, i64 16384, i64 288]
+!CHECK: @.offload_sizes{{.*}} = private unnamed_addr constant [7 x i64] [i64 4, i64 0, i64 40, i64 0, i64 0, i64 0, i64 0]
+!CHECK: @.offload_maptypes{{.*}} = private unnamed_addr constant [7 x i64] [i64 35, i64 545, i64 562949953421829, i64 515, i64 16384, i64 16384, i64 288]
+!CHECK: @.offload_sizes{{.*}} = private unnamed_addr constant [3 x i64] [i64 4, i64 48, i64 0]
+!CHECK: @.offload_maptypes{{.*}} = private unnamed_addr constant [3 x i64] [i64 35, i64 547, i64 288]
+!CHECK: @.offload_sizes{{.*}} = private unnamed_addr constant [7 x i64] [i64 0, i64 64, i64 0, i64 4, i64 0, i64 0, i64 0]
+!CHECK: @.offload_maptypes{{.*}} = private unnamed_addr constant [7 x i64] [i64 33, i64 281474976710661, i64 3, i64 35, i64 16384, i64 16384, i64 288]
+!CHECK: @.offload_sizes{{.*}} = private unnamed_addr constant [7 x i64] [i64 0, i64 64, i64 0, i64 4, i64 0, i64 0, i64 0]
+!CHECK: @.offload_maptypes{{.*}} = private unnamed_addr constant [7 x i64] [i64 33, i64 281474976710661, i64 3, i64 35, i64 16384, i64 16384, i64 288]
+
+module maptype_polymorphic_mod
+ type :: base_t
+ integer :: base
+ end type
+
+ type, extends(base_t) :: child_t
+ integer :: child
+ end type
+
+ type :: wrapper_t
+ integer :: marker
+ class(base_t), allocatable :: item
+ end type
+end module
+
+subroutine mapType_polymorphic_allocatable_explicit(obj, res)
+ use maptype_polymorphic_mod
+ class(base_t), allocatable :: obj
+ logical :: res
+
+!$omp target map(tofrom: obj, res)
+ obj%base = obj%base + 1
+ res = .true.
+!$omp end target
+end subroutine mapType_polymorphic_allocatable_explicit
+
+subroutine mapType_polymorphic_allocatable_implicit(obj, res)
+ use maptype_polymorphic_mod
+ class(base_t), allocatable :: obj
+ logical :: res
+
+!$omp target map(tofrom: res)
+ obj%base = obj%base + 1
+ res = .true.
+!$omp end target
+end subroutine mapType_polymorphic_allocatable_implicit
+
+subroutine mapType_polymorphic_nested_implicit(wrapper, res)
+ use maptype_polymorphic_mod
+ type(wrapper_t) :: wrapper
+ logical :: res
+
+!$omp target map(tofrom: res)
+ wrapper%item%base = wrapper%item%base + 1
+ wrapper%marker = wrapper%marker + 1
+ res = .true.
+!$omp end target
+end subroutine mapType_polymorphic_nested_implicit
+
+subroutine mapType_polymorphic_array_section_explicit(obj, res)
+ use maptype_polymorphic_mod
+ class(base_t), allocatable :: obj(:)
+ integer :: res
+
+!$omp target map(tofrom: obj(2:5), res)
+ obj(2)%base = obj(2)%base + 1
+ res = 1
+!$omp end target
+end subroutine mapType_polymorphic_array_section_explicit
+
+subroutine mapType_polymorphic_array_whole_explicit(obj, res)
+ use maptype_polymorphic_mod
+ class(base_t), allocatable :: obj(:)
+ integer :: res
+
+!$omp target map(tofrom: obj, res)
+ obj(1)%base = obj(1)%base + 1
+ res = 1
+!$omp end target
+end subroutine mapType_polymorphic_array_whole_explicit
!CHECK-LABEL: define {{.*}} @{{.*}}maptype_ptr_explicit_{{.*}}
!CHECK: %[[ALLOCA:.*]] = alloca { ptr, i64, i32, i8, i8, i8, i8 }, i64 1, align 8
@@ -838,3 +919,323 @@ end subroutine mapType_common_block_members
!CHECK: store ptr getelementptr inbounds nuw (i8, ptr @var_common_, i64 4), ptr %[[BASE_PTR_ARR_1]], align 8
!CHECK: %[[OFFLOAD_PTR_ARR_1:.*]] = getelementptr inbounds [3 x ptr], ptr %.offload_ptrs, i32 0, i32 1
!CHECK: store ptr getelementptr inbounds nuw (i8, ptr @var_common_, i64 4), ptr %[[OFFLOAD_PTR_ARR_1]], align 8
+
+!CHECK-LABEL: define {{.*}} @{{.*}}maptype_polymorphic_allocatable_explicit_{{.*}}
+!CHECK: %.offload_baseptrs = alloca [7 x ptr], align 8
+!CHECK: %.offload_ptrs = alloca [7 x ptr], align 8
+!CHECK: %.offload_mappers = alloca [7 x ptr], align 8
+!CHECK: %.offload_sizes = alloca [7 x i64], align 8
+!CHECK: %[[BASE_ADDR_FIELD:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] }, ptr %[[DESC:.*]], i32 0, i32 0
+!CHECK: %[[ELEM_LEN_FIELD:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] }, ptr %{{.*}}, i32 0, i32 1
+!CHECK: %[[ELEM_LEN:.*]] = load i64, ptr %[[ELEM_LEN_FIELD]], align 8
+!CHECK: %[[UB:.*]] = sub i64 %[[ELEM_LEN]], 1
+!CHECK: %[[RTTI_FIELD:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] }, ptr %[[DESC]], i32 0, i32 7
+!CHECK: %[[COUNT_SUB:.*]] = sub i64 %[[UB]], 0
+!CHECK: %[[COUNT_ADD:.*]] = add i64 %[[COUNT_SUB]], 1
+!CHECK: %[[COUNT_MUL:.*]] = mul i64 1, %[[COUNT_ADD]]
+!CHECK: %[[ELEMENT_COUNT:.*]] = mul i64 %[[COUNT_MUL]], 1
+!CHECK: %[[COUNT_CMP:.*]] = icmp eq i64 %[[ELEMENT_COUNT]], 0
+!CHECK: %[[COUNT_SEL:.*]] = select i1 %[[COUNT_CMP]], i64 1, i64 %[[ELEMENT_COUNT]]
+!CHECK: %[[LOAD_BASE_ADDR:.*]] = load ptr, ptr %[[BASE_ADDR_FIELD]], align 8
+!CHECK: %[[ARRAY_OFFSET:.*]] = getelementptr inbounds i8, ptr %[[LOAD_BASE_ADDR]], i64 0
+!CHECK: %[[LOAD_RTTI:.*]] = load ptr, ptr %[[RTTI_FIELD]], align 8
+!CHECK: %[[LOAD_BASE_ADDR2:.*]] = load ptr, ptr %[[BASE_ADDR_FIELD]], align 8
+!CHECK: %[[ARRAY_OFFSET1:.*]] = getelementptr inbounds i8, ptr %[[LOAD_BASE_ADDR2]], i64 0
+!CHECK: %[[DESC_END:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] }, ptr %[[DESC]], i32 1
+!CHECK: %[[DESC_END_INT:.*]] = ptrtoaddr ptr %[[DESC_END]] to i64
+!CHECK: %[[DESC_BEGIN_INT:.*]] = ptrtoaddr ptr %[[DESC]] to i64
+!CHECK: %[[DESC_SIZE:.*]] = sub i64 %[[DESC_END_INT]], %[[DESC_BEGIN_INT]]
+!CHECK: %[[DATA_CMP:.*]] = icmp eq ptr %[[ARRAY_OFFSET1]], null
+!CHECK: %[[DATA_SIZE:.*]] = select i1 %[[DATA_CMP]], i64 0, i64 %[[COUNT_SEL]]
+!CHECK: %[[SEG_CMP:.*]] = icmp eq ptr %[[ARRAY_OFFSET]], null
+!CHECK: %[[SEG_SIZE:.*]] = select i1 %[[SEG_CMP]], i64 0, i64 40
+!CHECK: %[[ATTACH_CMP:.*]] = icmp eq ptr %[[LOAD_RTTI]], null
+!CHECK: %[[ATTACH_SIZE:.*]] = select i1 %[[ATTACH_CMP]], i64 0, i64 8
+!CHECK: call void @llvm.memcpy{{.*}}ptr align 8 %.offload_sizes, ptr align 8 @.offload_sizes{{.*}}
+!CHECK: %[[BASE0:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_baseptrs, i32 0, i32 0
+!CHECK: store ptr %[[DESC]], ptr %[[BASE0]], align 8
+!CHECK: %[[PTR0:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_ptrs, i32 0, i32 0
+!CHECK: store ptr %[[DESC]], ptr %[[PTR0]], align 8
+!CHECK: %[[SIZE0:.*]] = getelementptr inbounds [7 x i64], ptr %.offload_sizes, i32 0, i32 0
+!CHECK: store i64 %[[DESC_SIZE]], ptr %[[SIZE0]], align 8
+!CHECK: %[[BASE1:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_baseptrs, i32 0, i32 1
+!CHECK: store ptr %[[DESC]], ptr %[[BASE1]], align 8
+!CHECK: %[[PTR1:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_ptrs, i32 0, i32 1
+!CHECK: store ptr %[[DESC]], ptr %[[PTR1]], align 8
+!CHECK: %[[BASE2:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_baseptrs, i32 0, i32 2
+!CHECK: store ptr %[[DESC]], ptr %[[BASE2]], align 8
+!CHECK: %[[PTR2:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_ptrs, i32 0, i32 2
+!CHECK: store ptr %[[ARRAY_OFFSET1]], ptr %[[PTR2]], align 8
+!CHECK: %[[SIZE2:.*]] = getelementptr inbounds [7 x i64], ptr %.offload_sizes, i32 0, i32 2
+!CHECK: store i64 %[[DATA_SIZE]], ptr %[[SIZE2]], align 8
+!CHECK: %[[BASE3:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_baseptrs, i32 0, i32 3
+!CHECK: store ptr %[[RES:.*]], ptr %[[BASE3]], align 8
+!CHECK: %[[PTR3:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_ptrs, i32 0, i32 3
+!CHECK: store ptr %[[RES]], ptr %[[PTR3]], align 8
+!CHECK: %[[BASE4:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_baseptrs, i32 0, i32 4
+!CHECK: store ptr %[[DESC]], ptr %[[BASE4]], align 8
+!CHECK: %[[PTR4:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_ptrs, i32 0, i32 4
+!CHECK: store ptr %[[ARRAY_OFFSET]], ptr %[[PTR4]], align 8
+!CHECK: %[[SIZE4:.*]] = getelementptr inbounds [7 x i64], ptr %.offload_sizes, i32 0, i32 4
+!CHECK: store i64 %[[SEG_SIZE]], ptr %[[SIZE4]], align 8
+!CHECK: %[[BASE5:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_baseptrs, i32 0, i32 5
+!CHECK: store ptr %[[RTTI_FIELD]], ptr %[[BASE5]], align 8
+!CHECK: %[[PTR5:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_ptrs, i32 0, i32 5
+!CHECK: store ptr %[[LOAD_RTTI]], ptr %[[PTR5]], align 8
+!CHECK: %[[SIZE5:.*]] = getelementptr inbounds [7 x i64], ptr %.offload_sizes, i32 0, i32 5
+!CHECK: store i64 %[[ATTACH_SIZE]], ptr %[[SIZE5]], align 8
+!CHECK: %[[BASE6:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_baseptrs, i32 0, i32 6
+!CHECK: store ptr null, ptr %[[BASE6]], align 8
+!CHECK: %[[PTR6:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_ptrs, i32 0, i32 6
+!CHECK: store ptr null, ptr %[[PTR6]], align 8
+
+!CHECK-LABEL: define {{.*}} @{{.*}}maptype_polymorphic_allocatable_implicit_{{.*}}
+!CHECK: %.offload_baseptrs = alloca [7 x ptr], align 8
+!CHECK: %.offload_ptrs = alloca [7 x ptr], align 8
+!CHECK: %.offload_mappers = alloca [7 x ptr], align 8
+!CHECK: %.offload_sizes = alloca [7 x i64], align 8
+!CHECK: %[[BASE_ADDR_FIELD:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] }, ptr %[[DESC:.*]], i32 0, i32 0
+!CHECK: %[[ELEM_LEN_FIELD:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] }, ptr %{{.*}}, i32 0, i32 1
+!CHECK: %[[ELEM_LEN:.*]] = load i64, ptr %[[ELEM_LEN_FIELD]], align 8
+!CHECK: %[[UB:.*]] = sub i64 %[[ELEM_LEN]], 1
+!CHECK: %[[RTTI_FIELD:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] }, ptr %[[DESC]], i32 0, i32 7
+!CHECK: %[[COUNT_SEL:.*]] = select i1 %{{.*}}, i64 1, i64 %{{.*}}
+!CHECK: %[[LOAD_BASE_ADDR:.*]] = load ptr, ptr %[[BASE_ADDR_FIELD]], align 8
+!CHECK: %[[ARRAY_OFFSET:.*]] = getelementptr inbounds i8, ptr %[[LOAD_BASE_ADDR]], i64 0
+!CHECK: %[[LOAD_RTTI:.*]] = load ptr, ptr %[[RTTI_FIELD]], align 8
+!CHECK: %[[LOAD_BASE_ADDR2:.*]] = load ptr, ptr %[[BASE_ADDR_FIELD]], align 8
+!CHECK: %[[ARRAY_OFFSET1:.*]] = getelementptr inbounds i8, ptr %[[LOAD_BASE_ADDR2]], i64 0
+!CHECK: %[[DESC_END:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] }, ptr %[[DESC]], i32 1
+!CHECK: %[[DESC_END_INT:.*]] = ptrtoaddr ptr %[[DESC_END]] to i64
+!CHECK: %[[DESC_BEGIN_INT:.*]] = ptrtoaddr ptr %[[DESC]] to i64
+!CHECK: %[[DESC_SIZE:.*]] = sub i64 %[[DESC_END_INT]], %[[DESC_BEGIN_INT]]
+!CHECK: %[[DATA_CMP:.*]] = icmp eq ptr %[[ARRAY_OFFSET1]], null
+!CHECK: %[[DATA_SIZE:.*]] = select i1 %[[DATA_CMP]], i64 0, i64 %[[COUNT_SEL]]
+!CHECK: %[[SEG_CMP:.*]] = icmp eq ptr %[[ARRAY_OFFSET]], null
+!CHECK: %[[SEG_SIZE:.*]] = select i1 %[[SEG_CMP]], i64 0, i64 40
+!CHECK: %[[ATTACH_CMP:.*]] = icmp eq ptr %[[LOAD_RTTI]], null
+!CHECK: %[[ATTACH_SIZE:.*]] = select i1 %[[ATTACH_CMP]], i64 0, i64 8
+!CHECK: call void @llvm.memcpy{{.*}}ptr align 8 %.offload_sizes, ptr align 8 @.offload_sizes{{.*}}
+!CHECK: %[[BASE0:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_baseptrs, i32 0, i32 0
+!CHECK: store ptr %[[RES:.*]], ptr %[[BASE0]], align 8
+!CHECK: %[[PTR0:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_ptrs, i32 0, i32 0
+!CHECK: store ptr %[[RES]], ptr %[[PTR0]], align 8
+!CHECK: %[[BASE1:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_baseptrs, i32 0, i32 1
+!CHECK: store ptr %[[DESC]], ptr %[[BASE1]], align 8
+!CHECK: %[[PTR1:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_ptrs, i32 0, i32 1
+!CHECK: store ptr %[[DESC]], ptr %[[PTR1]], align 8
+!CHECK: %[[SIZE1:.*]] = getelementptr inbounds [7 x i64], ptr %.offload_sizes, i32 0, i32 1
+!CHECK: store i64 %[[DESC_SIZE]], ptr %[[SIZE1]], align 8
+!CHECK: %[[BASE2:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_baseptrs, i32 0, i32 2
+!CHECK: store ptr %[[DESC]], ptr %[[BASE2]], align 8
+!CHECK: %[[PTR2:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_ptrs, i32 0, i32 2
+!CHECK: store ptr %[[DESC]], ptr %[[PTR2]], align 8
+!CHECK: %[[BASE3:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_baseptrs, i32 0, i32 3
+!CHECK: store ptr %[[DESC]], ptr %[[BASE3]], align 8
+!CHECK: %[[PTR3:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_ptrs, i32 0, i32 3
+!CHECK: store ptr %[[ARRAY_OFFSET1]], ptr %[[PTR3]], align 8
+!CHECK: %[[SIZE3:.*]] = getelementptr inbounds [7 x i64], ptr %.offload_sizes, i32 0, i32 3
+!CHECK: store i64 %[[DATA_SIZE]], ptr %[[SIZE3]], align 8
+!CHECK: %[[BASE4:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_baseptrs, i32 0, i32 4
+!CHECK: store ptr %[[DESC]], ptr %[[BASE4]], align 8
+!CHECK: %[[PTR4:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_ptrs, i32 0, i32 4
+!CHECK: store ptr %[[ARRAY_OFFSET]], ptr %[[PTR4]], align 8
+!CHECK: %[[SIZE4:.*]] = getelementptr inbounds [7 x i64], ptr %.offload_sizes, i32 0, i32 4
+!CHECK: store i64 %[[SEG_SIZE]], ptr %[[SIZE4]], align 8
+!CHECK: %[[BASE5:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_baseptrs, i32 0, i32 5
+!CHECK: store ptr %[[RTTI_FIELD]], ptr %[[BASE5]], align 8
+!CHECK: %[[PTR5:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_ptrs, i32 0, i32 5
+!CHECK: store ptr %[[LOAD_RTTI]], ptr %[[PTR5]], align 8
+!CHECK: %[[SIZE5:.*]] = getelementptr inbounds [7 x i64], ptr %.offload_sizes, i32 0, i32 5
+!CHECK: store i64 %[[ATTACH_SIZE]], ptr %[[SIZE5]], align 8
+!CHECK: %[[BASE6:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_baseptrs, i32 0, i32 6
+!CHECK: store ptr null, ptr %[[BASE6]], align 8
+!CHECK: %[[PTR6:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_ptrs, i32 0, i32 6
+!CHECK: store ptr null, ptr %[[PTR6]], align 8
+
+!CHECK-LABEL: define {{.*}} @{{.*}}maptype_polymorphic_nested_implicit_{{.*}}
+!CHECK: %.offload_baseptrs = alloca [3 x ptr], align 8
+!CHECK: %.offload_ptrs = alloca [3 x ptr], align 8
+!CHECK: %.offload_mappers = alloca [3 x ptr], align 8
+!CHECK: %[[BASE0:.*]] = getelementptr inbounds [3 x ptr], ptr %.offload_baseptrs, i32 0, i32 0
+!CHECK: store ptr %[[RES:.*]], ptr %[[BASE0]], align 8
+!CHECK: %[[PTR0:.*]] = getelementptr inbounds [3 x ptr], ptr %.offload_ptrs, i32 0, i32 0
+!CHECK: store ptr %[[RES]], ptr %[[PTR0]], align 8
+!CHECK: %[[MAPPER0:.*]] = getelementptr inbounds [3 x ptr], ptr %.offload_mappers, i64 0, i64 0
+!CHECK: store ptr null, ptr %[[MAPPER0]], align 8
+!CHECK: %[[BASE1:.*]] = getelementptr inbounds [3 x ptr], ptr %.offload_baseptrs, i32 0, i32 1
+!CHECK: store ptr %[[WRAPPER:.*]], ptr %[[BASE1]], align 8
+!CHECK: %[[PTR1:.*]] = getelementptr inbounds [3 x ptr], ptr %.offload_ptrs, i32 0, i32 1
+!CHECK: store ptr %[[WRAPPER]], ptr %[[PTR1]], align 8
+!CHECK: %[[MAPPER1:.*]] = getelementptr inbounds [3 x ptr], ptr %.offload_mappers, i64 0, i64 1
+!CHECK: store ptr @.omp_mapper.{{.*}}wrapper_t_omp_default_mapper, ptr %[[MAPPER1]], align 8
+!CHECK: %[[BASE2:.*]] = getelementptr inbounds [3 x ptr], ptr %.offload_baseptrs, i32 0, i32 2
+!CHECK: store ptr null, ptr %[[BASE2]], align 8
+!CHECK: %[[PTR2:.*]] = getelementptr inbounds [3 x ptr], ptr %.offload_ptrs, i32 0, i32 2
+!CHECK: store ptr null, ptr %[[PTR2]], align 8
+!CHECK: %[[MAPPER2:.*]] = getelementptr inbounds [3 x ptr], ptr %.offload_mappers, i64 0, i64 2
+!CHECK: store ptr null, ptr %[[MAPPER2]], align 8
+
+!CHECK-LABEL: define {{.*}} @{{.*}}maptype_polymorphic_array_section_explicit_{{.*}}
+!CHECK: %.offload_baseptrs = alloca [7 x ptr], align 8
+!CHECK: %.offload_ptrs = alloca [7 x ptr], align 8
+!CHECK: %.offload_mappers = alloca [7 x ptr], align 8
+!CHECK: %.offload_sizes = alloca [7 x i64], align 8
+!CHECK: %[[SECTION_LB_ACCESS:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]], ptr, [1 x i64] }, ptr %{{.*}}, i32 0, i32 7, i64 0, i32 0
+!CHECK: %[[SECTION_LB:.*]] = load i64, ptr %[[SECTION_LB_ACCESS]], align 8
+!CHECK: %[[LB_OFFSET:.*]] = sub i64 2, %[[SECTION_LB]]
+!CHECK: %[[UB_OFFSET:.*]] = sub i64 5, %[[SECTION_LB]]
+!CHECK: %[[BASE_ADDR_FIELD:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]], ptr, [1 x i64] }, ptr %[[DESC:.*]], i32 0, i32 0
+!CHECK: %[[ELEM_LEN_FIELD:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]], ptr, [1 x i64] }, ptr %{{.*}}, i32 0, i32 1
+!CHECK: %[[ELEM_LEN:.*]] = load i64, ptr %[[ELEM_LEN_FIELD]], align 8
+!CHECK: %[[EXTENT:.*]] = sub i64 %[[UB_OFFSET]], %[[LB_OFFSET]]
+!CHECK: %[[EXTENT_1:.*]] = add i64 %[[EXTENT]], 1
+!CHECK: %[[LB_BYTE_OFFSET:.*]] = mul i64 %[[LB_OFFSET]], %[[ELEM_LEN]]
+!CHECK: %[[EXTENT_BYTES:.*]] = mul i64 %[[EXTENT_1]], %[[ELEM_LEN]]
+!CHECK: %[[UB_BYTES:.*]] = add i64 %[[LB_BYTE_OFFSET]], %[[EXTENT_BYTES]]
+!CHECK: %[[UB_BYTES_1:.*]] = sub i64 %[[UB_BYTES]], 1
+!CHECK: %[[ELEM_LEN_FIELD2:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]], ptr, [1 x i64] }, ptr %{{.*}}, i32 0, i32 1
+!CHECK: %[[ELEM_LEN2:.*]] = load i64, ptr %[[ELEM_LEN_FIELD2]], align 8
+!CHECK: %[[SEG_LB_BYTES:.*]] = mul i64 %[[LB_OFFSET]], %[[ELEM_LEN2]]
+!CHECK: %[[RTTI_FIELD:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]], ptr, [1 x i64] }, ptr %[[DESC]], i32 0, i32 8
+!CHECK: %[[COUNT_RANGE:.*]] = sub i64 %[[UB_BYTES_1]], %[[LB_BYTE_OFFSET]]
+!CHECK: %[[COUNT_RANGE_1:.*]] = add i64 %[[COUNT_RANGE]], 1
+!CHECK: %[[COUNT_MUL:.*]] = mul i64 1, %[[COUNT_RANGE_1]]
+!CHECK: %[[ELEMENT_COUNT:.*]] = mul i64 %[[COUNT_MUL]], 1
+!CHECK: %[[COUNT_CMP:.*]] = icmp eq i64 %[[ELEMENT_COUNT]], 0
+!CHECK: %[[COUNT_SEL:.*]] = select i1 %[[COUNT_CMP]], i64 1, i64 %[[ELEMENT_COUNT]]
+!CHECK: %[[LOAD_BASE_ADDR:.*]] = load ptr, ptr %[[BASE_ADDR_FIELD]], align 8
+!CHECK: %[[ARRAY_OFFSET:.*]] = getelementptr inbounds i8, ptr %[[LOAD_BASE_ADDR]], i64 %[[SEG_LB_BYTES]]
+!CHECK: %[[LOAD_RTTI:.*]] = load ptr, ptr %[[RTTI_FIELD]], align 8
+!CHECK: %[[LOAD_BASE_ADDR2:.*]] = load ptr, ptr %[[BASE_ADDR_FIELD]], align 8
+!CHECK: %[[ARRAY_OFFSET1:.*]] = getelementptr inbounds i8, ptr %[[LOAD_BASE_ADDR2]], i64 %[[LB_BYTE_OFFSET]]
+!CHECK: %[[DESC_END:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]], ptr, [1 x i64] }, ptr %[[DESC]], i32 1
+!CHECK: %[[DESC_END_INT:.*]] = ptrtoaddr ptr %[[DESC_END]] to i64
+!CHECK: %[[DESC_BEGIN_INT:.*]] = ptrtoaddr ptr %[[DESC]] to i64
+!CHECK: %[[DESC_SIZE:.*]] = sub i64 %[[DESC_END_INT]], %[[DESC_BEGIN_INT]]
+!CHECK: %[[DATA_CMP:.*]] = icmp eq ptr %[[ARRAY_OFFSET1]], null
+!CHECK: %[[DATA_SIZE:.*]] = select i1 %[[DATA_CMP]], i64 0, i64 %[[COUNT_SEL]]
+!CHECK: %[[SEG_CMP:.*]] = icmp eq ptr %[[ARRAY_OFFSET]], null
+!CHECK: %[[SEG_SIZE:.*]] = select i1 %[[SEG_CMP]], i64 0, i64 64
+!CHECK: %[[ATTACH_CMP:.*]] = icmp eq ptr %[[LOAD_RTTI]], null
+!CHECK: %[[ATTACH_SIZE:.*]] = select i1 %[[ATTACH_CMP]], i64 0, i64 8
+!CHECK: call void @llvm.memcpy{{.*}}ptr align 8 %.offload_sizes, ptr align 8 @.offload_sizes{{.*}}
+!CHECK: %[[BASE0:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_baseptrs, i32 0, i32 0
+!CHECK: store ptr %[[DESC]], ptr %[[BASE0]], align 8
+!CHECK: %[[PTR0:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_ptrs, i32 0, i32 0
+!CHECK: store ptr %[[DESC]], ptr %[[PTR0]], align 8
+!CHECK: %[[SIZE0:.*]] = getelementptr inbounds [7 x i64], ptr %.offload_sizes, i32 0, i32 0
+!CHECK: store i64 %[[DESC_SIZE]], ptr %[[SIZE0]], align 8
+!CHECK: %[[BASE1:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_baseptrs, i32 0, i32 1
+!CHECK: store ptr %[[DESC]], ptr %[[BASE1]], align 8
+!CHECK: %[[PTR1:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_ptrs, i32 0, i32 1
+!CHECK: store ptr %[[DESC]], ptr %[[PTR1]], align 8
+!CHECK: %[[BASE2:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_baseptrs, i32 0, i32 2
+!CHECK: store ptr %[[DESC]], ptr %[[BASE2]], align 8
+!CHECK: %[[PTR2:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_ptrs, i32 0, i32 2
+!CHECK: store ptr %[[ARRAY_OFFSET1]], ptr %[[PTR2]], align 8
+!CHECK: %[[SIZE2:.*]] = getelementptr inbounds [7 x i64], ptr %.offload_sizes, i32 0, i32 2
+!CHECK: store i64 %[[DATA_SIZE]], ptr %[[SIZE2]], align 8
+!CHECK: %[[BASE3:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_baseptrs, i32 0, i32 3
+!CHECK: store ptr %[[RES:.*]], ptr %[[BASE3]], align 8
+!CHECK: %[[PTR3:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_ptrs, i32 0, i32 3
+!CHECK: store ptr %[[RES]], ptr %[[PTR3]], align 8
+!CHECK: %[[BASE4:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_baseptrs, i32 0, i32 4
+!CHECK: store ptr %[[DESC]], ptr %[[BASE4]], align 8
+!CHECK: %[[PTR4:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_ptrs, i32 0, i32 4
+!CHECK: store ptr %[[ARRAY_OFFSET]], ptr %[[PTR4]], align 8
+!CHECK: %[[SIZE4:.*]] = getelementptr inbounds [7 x i64], ptr %.offload_sizes, i32 0, i32 4
+!CHECK: store i64 %[[SEG_SIZE]], ptr %[[SIZE4]], align 8
+!CHECK: %[[BASE5:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_baseptrs, i32 0, i32 5
+!CHECK: store ptr %[[RTTI_FIELD]], ptr %[[BASE5]], align 8
+!CHECK: %[[PTR5:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_ptrs, i32 0, i32 5
+!CHECK: store ptr %[[LOAD_RTTI]], ptr %[[PTR5]], align 8
+!CHECK: %[[SIZE5:.*]] = getelementptr inbounds [7 x i64], ptr %.offload_sizes, i32 0, i32 5
+!CHECK: store i64 %[[ATTACH_SIZE]], ptr %[[SIZE5]], align 8
+!CHECK: %[[BASE6:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_baseptrs, i32 0, i32 6
+!CHECK: store ptr null, ptr %[[BASE6]], align 8
+!CHECK: %[[PTR6:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_ptrs, i32 0, i32 6
+!CHECK: store ptr null, ptr %[[PTR6]], align 8
+
+!CHECK-LABEL: define {{.*}} @{{.*}}maptype_polymorphic_array_whole_explicit_{{.*}}
+!CHECK: %.offload_baseptrs = alloca [7 x ptr], align 8
+!CHECK: %.offload_ptrs = alloca [7 x ptr], align 8
+!CHECK: %.offload_mappers = alloca [7 x ptr], align 8
+!CHECK: %.offload_sizes = alloca [7 x i64], align 8
+!CHECK: %[[EXTENT_ACCESS:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]], ptr, [1 x i64] }, ptr %{{.*}}, i32 0, i32 7, i64 0, i32 1
+!CHECK: %[[EXTENT:.*]] = load i64, ptr %[[EXTENT_ACCESS]], align 8
+!CHECK: %[[BASE_ADDR_FIELD:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]], ptr, [1 x i64] }, ptr %[[DESC:.*]], i32 0, i32 0
+!CHECK: %[[ELEM_LEN_FIELD:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]], ptr, [1 x i64] }, ptr %{{.*}}, i32 0, i32 1
+!CHECK: %[[ELEM_LEN:.*]] = load i64, ptr %[[ELEM_LEN_FIELD]], align 8
+!CHECK: %[[EXTENT_BYTES:.*]] = mul i64 %[[EXTENT]], %[[ELEM_LEN]]
+!CHECK: %[[UB_BYTES:.*]] = sub i64 %[[EXTENT_BYTES]], 1
+!CHECK: %[[ELEM_LEN_FIELD2:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]], ptr, [1 x i64] }, ptr %{{.*}}, i32 0, i32 1
+!CHECK: %[[ELEM_LEN2:.*]] = load i64, ptr %[[ELEM_LEN_FIELD2]], align 8
+!CHECK: %[[EXTENT_BYTES2:.*]] = mul i64 %[[EXTENT]], %[[ELEM_LEN2]]
+!CHECK: %[[UB_BYTES2:.*]] = sub i64 %[[EXTENT_BYTES2]], 1
+!CHECK: %[[RTTI_FIELD:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]], ptr, [1 x i64] }, ptr %[[DESC]], i32 0, i32 8
+!CHECK: %[[COUNT_RANGE:.*]] = sub i64 %[[UB_BYTES]], 0
+!CHECK: %[[COUNT_RANGE_1:.*]] = add i64 %[[COUNT_RANGE]], 1
+!CHECK: %[[COUNT_MUL:.*]] = mul i64 1, %[[COUNT_RANGE_1]]
+!CHECK: %[[ELEMENT_COUNT:.*]] = mul i64 %[[COUNT_MUL]], 1
+!CHECK: %[[COUNT_CMP:.*]] = icmp eq i64 %[[ELEMENT_COUNT]], 0
+!CHECK: %[[COUNT_SEL:.*]] = select i1 %[[COUNT_CMP]], i64 1, i64 %[[ELEMENT_COUNT]]
+!CHECK: %[[LOAD_BASE_ADDR:.*]] = load ptr, ptr %[[BASE_ADDR_FIELD]], align 8
+!CHECK: %[[ARRAY_OFFSET:.*]] = getelementptr inbounds i8, ptr %[[LOAD_BASE_ADDR]], i64 0
+!CHECK: %[[LOAD_RTTI:.*]] = load ptr, ptr %[[RTTI_FIELD]], align 8
+!CHECK: %[[LOAD_BASE_ADDR2:.*]] = load ptr, ptr %[[BASE_ADDR_FIELD]], align 8
+!CHECK: %[[ARRAY_OFFSET1:.*]] = getelementptr inbounds i8, ptr %[[LOAD_BASE_ADDR2]], i64 0
+!CHECK: %[[DESC_END:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]], ptr, [1 x i64] }, ptr %[[DESC]], i32 1
+!CHECK: %[[DESC_END_INT:.*]] = ptrtoaddr ptr %[[DESC_END]] to i64
+!CHECK: %[[DESC_BEGIN_INT:.*]] = ptrtoaddr ptr %[[DESC]] to i64
+!CHECK: %[[DESC_SIZE:.*]] = sub i64 %[[DESC_END_INT]], %[[DESC_BEGIN_INT]]
+!CHECK: %[[DATA_CMP:.*]] = icmp eq ptr %[[ARRAY_OFFSET1]], null
+!CHECK: %[[DATA_SIZE:.*]] = select i1 %[[DATA_CMP]], i64 0, i64 %[[COUNT_SEL]]
+!CHECK: %[[SEG_CMP:.*]] = icmp eq ptr %[[ARRAY_OFFSET]], null
+!CHECK: %[[SEG_SIZE:.*]] = select i1 %[[SEG_CMP]], i64 0, i64 64
+!CHECK: %[[ATTACH_CMP:.*]] = icmp eq ptr %[[LOAD_RTTI]], null
+!CHECK: %[[ATTACH_SIZE:.*]] = select i1 %[[ATTACH_CMP]], i64 0, i64 8
+!CHECK: call void @llvm.memcpy{{.*}}ptr align 8 %.offload_sizes, ptr align 8 @.offload_sizes{{.*}}
+!CHECK: %[[BASE0:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_baseptrs, i32 0, i32 0
+!CHECK: store ptr %[[DESC]], ptr %[[BASE0]], align 8
+!CHECK: %[[PTR0:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_ptrs, i32 0, i32 0
+!CHECK: store ptr %[[DESC]], ptr %[[PTR0]], align 8
+!CHECK: %[[SIZE0:.*]] = getelementptr inbounds [7 x i64], ptr %.offload_sizes, i32 0, i32 0
+!CHECK: store i64 %[[DESC_SIZE]], ptr %[[SIZE0]], align 8
+!CHECK: %[[BASE1:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_baseptrs, i32 0, i32 1
+!CHECK: store ptr %[[DESC]], ptr %[[BASE1]], align 8
+!CHECK: %[[PTR1:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_ptrs, i32 0, i32 1
+!CHECK: store ptr %[[DESC]], ptr %[[PTR1]], align 8
+!CHECK: %[[BASE2:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_baseptrs, i32 0, i32 2
+!CHECK: store ptr %[[DESC]], ptr %[[BASE2]], align 8
+!CHECK: %[[PTR2:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_ptrs, i32 0, i32 2
+!CHECK: store ptr %[[ARRAY_OFFSET1]], ptr %[[PTR2]], align 8
+!CHECK: %[[SIZE2:.*]] = getelementptr inbounds [7 x i64], ptr %.offload_sizes, i32 0, i32 2
+!CHECK: store i64 %[[DATA_SIZE]], ptr %[[SIZE2]], align 8
+!CHECK: %[[BASE3:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_baseptrs, i32 0, i32 3
+!CHECK: store ptr %[[RES:.*]], ptr %[[BASE3]], align 8
+!CHECK: %[[PTR3:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_ptrs, i32 0, i32 3
+!CHECK: store ptr %[[RES]], ptr %[[PTR3]], align 8
+!CHECK: %[[BASE4:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_baseptrs, i32 0, i32 4
+!CHECK: store ptr %[[DESC]], ptr %[[BASE4]], align 8
+!CHECK: %[[PTR4:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_ptrs, i32 0, i32 4
+!CHECK: store ptr %[[ARRAY_OFFSET]], ptr %[[PTR4]], align 8
+!CHECK: %[[SIZE4:.*]] = getelementptr inbounds [7 x i64], ptr %.offload_sizes, i32 0, i32 4
+!CHECK: store i64 %[[SEG_SIZE]], ptr %[[SIZE4]], align 8
+!CHECK: %[[BASE5:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_baseptrs, i32 0, i32 5
+!CHECK: store ptr %[[RTTI_FIELD]], ptr %[[BASE5]], align 8
+!CHECK: %[[PTR5:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_ptrs, i32 0, i32 5
+!CHECK: store ptr %[[LOAD_RTTI]], ptr %[[PTR5]], align 8
+!CHECK: %[[SIZE5:.*]] = getelementptr inbounds [7 x i64], ptr %.offload_sizes, i32 0, i32 5
+!CHECK: store i64 %[[ATTACH_SIZE]], ptr %[[SIZE5]], align 8
+!CHECK: %[[BASE6:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_baseptrs, i32 0, i32 6
+!CHECK: store ptr null, ptr %[[BASE6]], align 8
+!CHECK: %[[PTR6:.*]] = getelementptr inbounds [7 x ptr], ptr %.offload_ptrs, i32 0, i32 6
+!CHECK: store ptr null, ptr %[[PTR6]], align 8
+
+!CHECK-LABEL: define internal void @.omp_mapper.{{.*}}wrapper_t_omp_default_mapper
+!CHECK: %[[ITEM_DESC:.*]] = getelementptr %{{.*}}Twrapper_t, ptr %{{.*}}, i32 0, i32 1
+!CHECK: %[[ELEM_LEN_FIELD:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] }, ptr %{{.*}}, i32 0, i32 1
+!CHECK: %[[ELEM_LEN:.*]] = load i64, ptr %[[ELEM_LEN_FIELD]], align 8
+!CHECK: %[[DYNAMIC_ITEM_SIZE:.*]] = select i1 %{{.*}}, i64 0, i64 %{{.*}}
+!CHECK: call void @.omp_mapper.{{.*}}base_t_omp_default_mapper(ptr %{{.*}}, ptr %{{.*}}, ptr %{{.*}}, i64 %[[DYNAMIC_ITEM_SIZE]], i64 %{{.*}}, ptr {{.*}}) {{.*}}
diff --git a/flang/test/Lower/OpenMP/allocatable-dtype-intermediate-map-gen.f90 b/flang/test/Lower/OpenMP/allocatable-dtype-intermediate-map-gen.f90
index 789fd1dafa8cb2..47711e29591bad 100644
--- a/flang/test/Lower/OpenMP/allocatable-dtype-intermediate-map-gen.f90
+++ b/flang/test/Lower/OpenMP/allocatable-dtype-intermediate-map-gen.f90
@@ -34,7 +34,7 @@ subroutine update_map_to()
allocate(derived%scalar)
!CHECK: %[[SCALAR_DATA:.*]] = omp.map.info var_ptr(%{{.*}} : !fir.ref<!fir.box<!fir.heap<i32>>>, !fir.box<!fir.heap<i32>>) map_clauses(to) capture(ByRef) var_ptr_ptr({{.*}} : !fir.llvm_ptr<!fir.ref<i32>>, i32) name("") -> !fir.llvm_ptr<!fir.ref<i32>>
-!CHECK: %[[SCALAR_DESC:.*]] = omp.map.info var_ptr(%{{.*}} : !fir.ref<!fir.box<!fir.heap<i32>>>, !fir.box<!fir.heap<i32>>) map_clauses(to) capture(ByRef) members{{.*}} : !fir.llvm_ptr<!fir.ref<i32>>) name("derived%scalar") -> !fir.heap<i32>
+!CHECK: %[[SCALAR_DESC:.*]] = omp.map.info var_ptr(%{{.*}} : !fir.ref<!fir.box<!fir.heap<i32>>>, !fir.box<!fir.heap<i32>>) map_clauses(to) capture(ByRef) members({{.*}} : !fir.llvm_ptr<!fir.ref<i32>>) name("derived%scalar") -> !fir.heap<i32>
!CHECK: %[[SCALAR_DESC_ATTACH:.*]] = omp.map.info var_ptr(%{{.*}} : !fir.ref<!fir.box<!fir.heap<i32>>>, !fir.box<!fir.heap<i32>>) map_clauses(attach, ref_ptr, ref_ptee) capture(ByRef) var_ptr_ptr(%{{.*}} : !fir.llvm_ptr<!fir.ref<i32>>, i32) name("derived%scalar") -> !fir.heap<i32>
!CHECK: omp.target_update map_entries(%[[SCALAR_DESC]], %[[SCALAR_DESC_ATTACH]], %[[SCALAR_DATA]] : !fir.heap<i32>, !fir.heap<i32>, !fir.llvm_ptr<!fir.ref<i32>>)
diff --git a/flang/test/Lower/OpenMP/polymorphic-derived-type-map.f90 b/flang/test/Lower/OpenMP/polymorphic-derived-type-map.f90
new file mode 100644
index 00000000000000..926d976e454bec
--- /dev/null
+++ b/flang/test/Lower/OpenMP/polymorphic-derived-type-map.f90
@@ -0,0 +1,50 @@
+! RUN: %flang_fc1 -emit-hlfir -fopenmp -fopenmp-version=61 %s -o - | FileCheck %s
+
+module polymorphic_derived_type_map
+ implicit none
+
+ type :: base_t
+ integer :: x
+ end type
+
+ type, extends(base_t) :: child_t
+ integer :: y
+ end type
+
+contains
+ subroutine map_polymorphic()
+ class(base_t), allocatable :: obj
+
+ allocate(child_t :: obj)
+
+ !$omp target enter data map(to: obj)
+
+ !$omp target map(tofrom: obj)
+ select type (obj)
+ type is (child_t)
+ obj%x = 1
+ obj%y = 2
+ end select
+ !$omp end target
+
+ !$omp target exit data map(from: obj)
+ end subroutine
+end module
+
+! CHECK: %[[BASE_ADDR:.*]] = fir.box_offset %{{.*}} base_addr
+! CHECK: %[[BASE_MAP:.*]] = omp.map.info {{.*}}var_ptr_ptr(%[[BASE_ADDR]]{{.*}})
+! CHECK: %[[DESC_MAP:.*]] = omp.map.info {{.*}}members(%[[BASE_MAP]] : {{\[}}0{{\]}}
+! CHECK: %[[BASE_ATTACH:.*]] = omp.map.info var_ptr({{.*}}) {{.*}}map_clauses(attach, ref_ptr, ref_ptee){{.*}}var_ptr_ptr(%[[BASE_ADDR]]
+! CHECK: %[[TYPE_DESC:.*]] = fir.box_offset %{{.*}} derived_type
+! CHECK-NOT: omp.map.info {{.*}}var_ptr_ptr(%[[TYPE_DESC]]{{.*}}!fir.type<_QM__fortran_type_infoTderivedtype>
+! CHECK: %[[TYPE_DESC_ATTACH:.*]] = omp.map.info var_ptr(%[[TYPE_DESC]]{{.*}}!fir.llvm_ptr<i8>) {{.*}}map_clauses(attach, ref_ptr, ref_ptee){{.*}}var_ptr_ptr(%[[TYPE_DESC]]{{.*}}!fir.llvm_ptr<i8>)
+! CHECK: omp.target_enter_data map_entries(%[[DESC_MAP]], %[[BASE_ATTACH]], %[[TYPE_DESC_ATTACH]], %[[BASE_MAP]]
+
+! CHECK: %[[TGT_BASE_ADDR:.*]] = fir.box_offset %{{.*}} base_addr
+! CHECK: %[[TGT_BASE_MAP:.*]] = omp.map.info {{.*}}var_ptr_ptr(%[[TGT_BASE_ADDR]]{{.*}})
+! CHECK: %[[TGT_DESC_MAP:.*]] = omp.map.info {{.*}}members(%[[TGT_BASE_MAP]] : {{\[}}0{{\]}}
+! CHECK: %[[TGT_BASE_ATTACH:.*]] = omp.map.info var_ptr({{.*}}) {{.*}}map_clauses(attach, ref_ptr, ref_ptee){{.*}}var_ptr_ptr(%[[TGT_BASE_ADDR]]
+! CHECK: %[[TGT_TYPE_DESC:.*]] = fir.box_offset %{{.*}} derived_type
+! CHECK-NOT: omp.map.info {{.*}}var_ptr_ptr(%[[TGT_TYPE_DESC]]{{.*}}!fir.type<_QM__fortran_type_infoTderivedtype>
+! CHECK: %[[TGT_TYPE_DESC_ATTACH:.*]] = omp.map.info var_ptr(%[[TGT_TYPE_DESC]]{{.*}}!fir.llvm_ptr<i8>) {{.*}}map_clauses(attach, ref_ptr, ref_ptee){{.*}}var_ptr_ptr(%[[TGT_TYPE_DESC]]{{.*}}!fir.llvm_ptr<i8>)
+! CHECK: omp.target {{.*}}map_entries(%[[TGT_DESC_MAP]] -> %{{.*}}, %[[TGT_BASE_ATTACH]] -> %{{.*}}, %[[TGT_TYPE_DESC_ATTACH]] -> %{{.*}}, %[[TGT_BASE_MAP]] -> %{{.*}}
diff --git a/flang/test/Semantics/OpenMP/target-polymorphic-derived-type-version.f90 b/flang/test/Semantics/OpenMP/target-polymorphic-derived-type-version.f90
new file mode 100644
index 00000000000000..88a8198c4b3811
--- /dev/null
+++ b/flang/test/Semantics/OpenMP/target-polymorphic-derived-type-version.f90
@@ -0,0 +1,111 @@
+! RUN: %python %S/../test_errors.py %s %flang -fopenmp -fopenmp-version=60
+
+module target_polymorphic_derived_type_version
+ implicit none
+
+ type :: base_t
+ integer :: x = 0
+ contains
+ procedure :: set_x
+ end type
+
+ type, extends(base_t) :: child_t
+ integer :: y = 0
+ end type
+
+contains
+ subroutine set_x(this)
+ class(base_t), intent(inout) :: this
+ this%x = 1
+ end subroutine
+
+ subroutine map_class_object()
+ class(base_t), allocatable :: obj
+ type(base_t) :: nonpoly
+
+ allocate(child_t :: obj)
+
+ ! TYPE(dt) is still valid before OpenMP 6.1.
+ !$omp target map(tofrom: nonpoly)
+ nonpoly%x = 1
+ !$omp end target
+
+ !ERROR: Polymorphic type 'obj' may not appear in a MAP clause on a target offload construct before OpenMP 6.1
+ !$omp target map(tofrom: obj)
+ !$omp end target
+
+ !ERROR: Polymorphic type 'obj' may not appear in a MAP clause on a target offload construct before OpenMP 6.1
+ !$omp target enter data map(to: obj)
+
+ !ERROR: Polymorphic type 'obj' may not appear in a MAP clause on a target offload construct before OpenMP 6.1
+ !$omp target exit data map(delete: obj)
+ end subroutine
+
+ subroutine map_unlimited_polymorphic_object()
+ class(*), allocatable :: any
+ type(base_t) :: nonpoly
+
+ allocate(child_t :: any)
+
+ ! TYPE(dt) is still valid before OpenMP 6.1.
+ !$omp target map(tofrom: nonpoly)
+ nonpoly%x = 1
+ !$omp end target
+
+ !ERROR: Polymorphic type 'any' may not appear in a MAP clause on a target offload construct before OpenMP 6.1
+ !$omp target map(tofrom: any)
+ !$omp end target
+
+ !ERROR: Polymorphic type 'any' may not appear in a MAP clause on a target offload construct before OpenMP 6.1
+ !$omp target data map(tofrom: any)
+ !$omp end target data
+
+ !ERROR: Polymorphic type 'any' may not appear in a MAP clause on a target offload construct before OpenMP 6.1
+ !$omp target enter data map(to: any)
+
+ !ERROR: Polymorphic type 'any' may not appear in a MAP clause on a target offload construct before OpenMP 6.1
+ !$omp target exit data map(delete: any)
+ end subroutine
+
+ subroutine map_class_component()
+ class(base_t), allocatable :: obj
+
+ allocate(child_t :: obj)
+
+ !ERROR: Polymorphic type 'obj' may not appear in a MAP clause on a target offload construct before OpenMP 6.1
+ !$omp target map(tofrom: obj%x)
+ !$omp end target
+ end subroutine
+
+ subroutine target_region_use()
+ class(base_t), allocatable :: obj
+ type(base_t) :: nonpoly
+
+ allocate(child_t :: obj)
+
+ !$omp target
+ nonpoly%x = 2
+ !$omp end target
+
+ !$omp target
+ !ERROR: Polymorphic type 'obj' may not be used in a target region before OpenMP 6.1
+ obj%x = 3
+ !$omp end target
+ end subroutine
+
+ subroutine target_region_unlimited_polymorphic_use()
+ class(*), allocatable :: any
+ type(base_t) :: nonpoly
+
+ allocate(child_t :: any)
+
+ !$omp target
+ nonpoly%x = 2
+ !$omp end target
+
+ !$omp target
+ !ERROR: Polymorphic type 'any' may not be used in a target region before OpenMP 6.1
+ if (same_type_as(any, nonpoly)) nonpoly%x = 3
+ !$omp end target
+ end subroutine
+end module
diff --git a/flang/test/Transforms/omp-map-info-finalization-polymorphic.fir b/flang/test/Transforms/omp-map-info-finalization-polymorphic.fir
new file mode 100644
index 00000000000000..4663e61f65ef26
--- /dev/null
+++ b/flang/test/Transforms/omp-map-info-finalization-polymorphic.fir
@@ -0,0 +1,43 @@
+// RUN: fir-opt --split-input-file --omp-map-info-finalization %s | FileCheck %s
+
+builtin.module attributes {omp.version = #omp.version<version = 61>} {
+ func.func @test_polymorphic_base_addr_runtime_size(%arg0: !fir.ref<!fir.class<!fir.ptr<!fir.type<base_t{base:i32}>>>>) {
+ %0 = omp.map.info var_ptr(%arg0 : !fir.ref<!fir.class<!fir.ptr<!fir.type<base_t{base:i32}>>>>, !fir.class<!fir.ptr<!fir.type<base_t{base:i32}>>>) map_clauses(tofrom) capture(ByRef) name("obj") -> !fir.ref<!fir.class<!fir.ptr<!fir.type<base_t{base:i32}>>>>
+ omp.target kernel_type(generic) map_entries(%0 -> %arg1 : !fir.ref<!fir.class<!fir.ptr<!fir.type<base_t{base:i32}>>>>) {
+ omp.terminator
+ }
+ return
+ }
+}
+
+// CHECK-LABEL: func.func @test_polymorphic_base_addr_runtime_size
+// CHECK-SAME: (%[[ARG0:.*]]: !fir.ref<!fir.class<!fir.ptr<!fir.type<base_t{base:i32}>>>>) {
+// CHECK: %[[BASE_ADDR:.*]] = fir.box_offset %[[ARG0]] base_addr : (!fir.ref<!fir.class<!fir.ptr<!fir.type<base_t{base:i32}>>>>) -> !fir.llvm_ptr<!fir.ref<!fir.type<base_t{base:i32}>>>
+// CHECK: %[[BOX:.*]] = fir.load %[[ARG0]] : !fir.ref<!fir.class<!fir.ptr<!fir.type<base_t{base:i32}>>>>
+// CHECK: %[[ELEM_SIZE:.*]] = fir.box_elesize %[[BOX]] : (!fir.class<!fir.ptr<!fir.type<base_t{base:i32}>>>) -> index
+// CHECK: %[[BYTE_OFFSET:.*]] = arith.muli %{{.*}}, %[[ELEM_SIZE]] : index
+// CHECK: %[[BYTE_EXTENT:.*]] = arith.muli %{{.*}}, %[[ELEM_SIZE]] : index
+// CHECK: %[[BYTE_END:.*]] = arith.addi %[[BYTE_OFFSET]], %[[BYTE_EXTENT]] : index
+// CHECK: %[[UPPER:.*]] = arith.subi %[[BYTE_END]], %{{.*}} : index
+// CHECK: %[[BOUND:.*]] = omp.map.bounds lower_bound(%[[BYTE_OFFSET]] : index) upper_bound(%[[UPPER]] : index) extent(%[[BYTE_EXTENT]] : index) stride(%{{.*}} : index) start_idx(%{{.*}} : index) stride_in_bytes(true)
+// CHECK: %[[BASE_MAP:.*]] = omp.map.info var_ptr(%[[ARG0]] : !fir.ref<!fir.class<!fir.ptr<!fir.type<base_t{base:i32}>>>>, !fir.class<!fir.ptr<!fir.type<base_t{base:i32}>>>) map_clauses(tofrom) capture(ByRef) var_ptr_ptr(%[[BASE_ADDR]] : !fir.llvm_ptr<!fir.ref<!fir.type<base_t{base:i32}>>>, i8) bounds(%[[BOUND]]) name("") -> !fir.llvm_ptr<!fir.ref<!fir.type<base_t{base:i32}>>>
+// CHECK: omp.map.info {{.*}} members(%[[BASE_MAP]] : [0] : !fir.llvm_ptr<!fir.ref<!fir.type<base_t{base:i32}>>>) name("obj")
+
+// -----
+
+builtin.module attributes {omp.version = #omp.version<version = 60>} {
+ func.func @test_polymorphic_base_addr_static_size_pre_61(%arg0: !fir.ref<!fir.class<!fir.ptr<!fir.type<base_t{base:i32}>>>>) {
+ %0 = omp.map.info var_ptr(%arg0 : !fir.ref<!fir.class<!fir.ptr<!fir.type<base_t{base:i32}>>>>, !fir.class<!fir.ptr<!fir.type<base_t{base:i32}>>>) map_clauses(tofrom) capture(ByRef) name("obj") -> !fir.ref<!fir.class<!fir.ptr<!fir.type<base_t{base:i32}>>>>
+ omp.target kernel_type(generic) map_entries(%0 -> %arg1 : !fir.ref<!fir.class<!fir.ptr<!fir.type<base_t{base:i32}>>>>) {
+ omp.terminator
+ }
+ return
+ }
+}
+
+// CHECK-LABEL: func.func @test_polymorphic_base_addr_static_size_pre_61
+// CHECK-SAME: (%[[ARG0:.*]]: !fir.ref<!fir.class<!fir.ptr<!fir.type<base_t{base:i32}>>>>) {
+// CHECK: %[[BASE_ADDR:.*]] = fir.box_offset %[[ARG0]] base_addr : (!fir.ref<!fir.class<!fir.ptr<!fir.type<base_t{base:i32}>>>>) -> !fir.llvm_ptr<!fir.ref<!fir.type<base_t{base:i32}>>>
+// CHECK-NOT: fir.box_elesize
+// CHECK-NOT: omp.map.bounds
+// CHECK: omp.map.info var_ptr(%[[ARG0]] : !fir.ref<!fir.class<!fir.ptr<!fir.type<base_t{base:i32}>>>>, !fir.class<!fir.ptr<!fir.type<base_t{base:i32}>>>) map_clauses(tofrom) capture(ByRef) var_ptr_ptr(%[[BASE_ADDR]] : !fir.llvm_ptr<!fir.ref<!fir.type<base_t{base:i32}>>>, !fir.type<base_t{base:i32}>) name("")
diff --git a/offload/test/offloading/fortran/target-implicit-map-polymorphic-dispatch.f90 b/offload/test/offloading/fortran/target-implicit-map-polymorphic-dispatch.f90
new file mode 100644
index 00000000000000..f4df13ecf76902
--- /dev/null
+++ b/offload/test/offloading/fortran/target-implicit-map-polymorphic-dispatch.f90
@@ -0,0 +1,218 @@
+! Offload tests for polymorphic objects captured by implicit target maps.
+!
+! These cases mirror explicit map polymorphic tests, but intentionally omit
+! the polymorphic list items from the map clauses so lowering must create
+! implicit maps for the captured class descriptors.
+!
+! REQUIRES: flang, amdgpu
+!
+! RUN: %libomptarget-compile-fortran-generic -fopenmp-version=61 && %libomptarget-run-generic | %fcheck-generic
+
+module implicit_map_polymorphic_dispatch_mod
+ implicit none
+
+ type :: base_t
+ integer :: base_value
+ contains
+ procedure :: value => base_value_fn
+ procedure :: adjust => base_adjust
+ end type base_t
+
+ type, extends(base_t) :: child_a_t
+ integer :: a_value
+ contains
+ procedure :: value => child_a_value_fn
+ procedure :: adjust => child_a_adjust
+ end type child_a_t
+
+ type, extends(base_t) :: child_b_t
+ integer :: b_value
+ contains
+ procedure :: value => child_b_value_fn
+ procedure :: adjust => child_b_adjust
+ end type child_b_t
+
+ type :: wrapper_t
+ integer :: marker
+ class(base_t), allocatable :: item
+ end type wrapper_t
+
+contains
+
+ integer function base_value_fn(self)
+ class(base_t), intent(in) :: self
+ base_value_fn = self%base_value
+ end function base_value_fn
+
+ subroutine base_adjust(self, amount)
+ class(base_t), intent(inout) :: self
+ integer, intent(in) :: amount
+ self%base_value = self%base_value + amount
+ end subroutine base_adjust
+
+ integer function child_a_value_fn(self)
+ class(child_a_t), intent(in) :: self
+ child_a_value_fn = self%base_value + self%a_value * 10
+ end function child_a_value_fn
+
+ subroutine child_a_adjust(self, amount)
+ class(child_a_t), intent(inout) :: self
+ integer, intent(in) :: amount
+ self%base_value = self%base_value + amount
+ self%a_value = self%a_value + 1
+ end subroutine child_a_adjust
+
+ integer function child_b_value_fn(self)
+ class(child_b_t), intent(in) :: self
+ child_b_value_fn = self%base_value + self%b_value * 100
+ end function child_b_value_fn
+
+ subroutine child_b_adjust(self, amount)
+ class(child_b_t), intent(inout) :: self
+ integer, intent(in) :: amount
+ self%base_value = self%base_value + amount * 2
+ self%b_value = self%b_value + 2
+ end subroutine child_b_adjust
+
+ subroutine init_wrapper(w)
+ type(wrapper_t), intent(out) :: w
+
+ w%marker = 5
+ allocate(child_b_t :: w%item)
+ w%item%base_value = 12
+ select type (item => w%item)
+ type is (child_b_t)
+ item%b_value = 3
+ class default
+ stop 1
+ end select
+ end subroutine init_wrapper
+
+end module implicit_map_polymorphic_dispatch_mod
+
+program main
+ use implicit_map_polymorphic_dispatch_mod
+ implicit none
+
+ class(base_t), allocatable :: section_arr(:)
+ class(base_t), allocatable :: whole_arr(:)
+ type(child_a_t), target :: ptr_a
+ type(child_b_t), target :: ptr_b
+ class(base_t), pointer :: ptr
+ type(wrapper_t) :: wrapped
+ type(base_t) :: base_mold
+ integer :: section_result
+ integer :: whole_result
+ integer :: pointer_result
+ logical :: extends_base
+ logical :: base_extends_item
+ logical :: failed
+
+ failed = .false.
+
+ allocate(child_a_t :: section_arr(10))
+ section_arr(:)%base_value = -100
+ section_arr(4)%base_value = 5
+ section_arr(10)%base_value = 11
+ select type (section_arr)
+ type is (child_a_t)
+ section_arr(:)%a_value = -10
+ section_arr(4)%a_value = 3
+ section_arr(10)%a_value = 6
+ class default
+ failed = .true.
+ end select
+
+ section_result = -1
+ ! The polymorphic array is deliberately not present in the map clause. This
+ ! checks that implicit capture uses runtime element-size bounds for the
+ ! dynamically typed array storage, as the explicit section-dispatch test does.
+ !$omp target map(tofrom: section_result)
+ section_result = section_arr(4)%value()
+ call section_arr(10)%adjust(4)
+ !$omp end target
+
+ if (section_result /= 35) failed = .true.
+ if (section_arr(10)%base_value /= 15) failed = .true.
+ select type (section_arr)
+ type is (child_a_t)
+ if (section_arr(10)%a_value /= 7) failed = .true.
+ class default
+ failed = .true.
+ end select
+
+ allocate(child_b_t :: whole_arr(2))
+ whole_arr(1)%base_value = 7
+ whole_arr(2)%base_value = 13
+ select type (whole_arr)
+ type is (child_b_t)
+ whole_arr(1)%b_value = 2
+ whole_arr(2)%b_value = 5
+ class default
+ failed = .true.
+ end select
+
+ whole_result = -1
+ ! Whole polymorphic array implicit capture: exercises dynamic dispatch and
+ ! copy-back of extended dynamic-type components without an explicit map.
+ !$omp target map(tofrom: whole_result)
+ whole_result = whole_arr(1)%value()
+ call whole_arr(2)%adjust(4)
+ !$omp end target
+
+ if (whole_result /= 207) failed = .true.
+ if (whole_arr(2)%base_value /= 21) failed = .true.
+ select type (whole_arr)
+ type is (child_b_t)
+ if (whole_arr(2)%b_value /= 7) failed = .true.
+ class default
+ failed = .true.
+ end select
+
+ ptr_a%base_value = 5
+ ptr_a%a_value = 3
+ ptr_b%base_value = 7
+ ptr_b%b_value = 2
+
+ ptr => ptr_a
+ pointer_result = -1
+ ! Polymorphic pointer implicit capture: verifies pointer descriptor RTTI and
+ ! dispatch still work when the pointer itself is not explicitly mapped.
+ !$omp target map(tofrom: pointer_result)
+ pointer_result = ptr%value()
+ call ptr%adjust(4)
+ !$omp end target
+
+ if (pointer_result /= 35) failed = .true.
+ if (ptr_a%base_value /= 9) failed = .true.
+ if (ptr_a%a_value /= 4) failed = .true.
+
+ call init_wrapper(wrapped)
+ extends_base = .false.
+ base_extends_item = .true.
+
+ ! Derived type with a nested allocatable polymorphic component. The wrapper is
+ ! implicitly mapped, so its generated default mapper must use runtime
+ ! element-size bounds for the nested class component while preserving RTTI
+ ! intrinsics and copy-back of the extended dynamic-type storage.
+ !$omp target map(tofrom: extends_base, base_extends_item) map(to: base_mold)
+ extends_base = extends_type_of(wrapped%item, base_mold)
+ base_extends_item = extends_type_of(base_mold, wrapped%item)
+ wrapped%marker = wrapped%marker + 1
+ wrapped%item%base_value = wrapped%item%base_value + 1
+ !$omp end target
+
+ if (.not. extends_base) failed = .true.
+ if (base_extends_item) failed = .true.
+ if (wrapped%marker /= 6) failed = .true.
+ if (wrapped%item%base_value /= 13) failed = .true.
+
+ if (failed) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ print *, "======= Test Passed! ======="
+end program main
+
+! CHECK: ======= Test Passed! =======
diff --git a/offload/test/offloading/fortran/target-map-polymorphic-abstract-base-rtti.f90 b/offload/test/offloading/fortran/target-map-polymorphic-abstract-base-rtti.f90
new file mode 100644
index 00000000000000..7b3033b4a8f855
--- /dev/null
+++ b/offload/test/offloading/fortran/target-map-polymorphic-abstract-base-rtti.f90
@@ -0,0 +1,84 @@
+! Offload test for polymorphic RTTI with an abstract declared type.
+!
+! An abstract base cannot be instantiated, so the mapped polymorphic descriptor
+! has an abstract declared type and a concrete extension dynamic type. The
+! target region uses SAME_TYPE_AS and EXTENDS_TYPE_OF with a concrete child
+! mold to verify device RTTI without SELECT TYPE in the target region.
+!
+! REQUIRES: flang, amdgpu
+!
+! RUN: %libomptarget-compile-fortran-generic -fopenmp-version=61 && %libomptarget-run-generic | %fcheck-generic
+
+module polymorphic_abstract_base_rtti_mod
+ implicit none
+
+ type, abstract :: abstract_base_t
+ integer :: base_value
+ end type abstract_base_t
+
+ type, extends(abstract_base_t) :: child_t
+ integer :: child_value
+ end type child_t
+
+end module polymorphic_abstract_base_rtti_mod
+
+program main
+ use polymorphic_abstract_base_rtti_mod
+ implicit none
+
+ class(abstract_base_t), allocatable :: obj
+ type(child_t) :: child_mold
+ logical :: same_child
+ logical :: extends_child
+ logical :: child_extends_obj
+
+ allocate(child_t :: obj)
+ obj%base_value = 8
+
+ select type (obj)
+ type is (child_t)
+ obj%child_value = 34
+ class default
+ print *, "======= Test Failed! ======="
+ stop 1
+ end select
+
+ same_child = .false.
+ extends_child = .false.
+ child_extends_obj = .false.
+
+ !$omp target enter data map(to: obj)
+
+ !$omp target map(tofrom: obj, same_child, extends_child, child_extends_obj) map(to: child_mold)
+ same_child = same_type_as(obj, child_mold)
+ extends_child = extends_type_of(obj, child_mold)
+ child_extends_obj = extends_type_of(child_mold, obj)
+ obj%base_value = obj%base_value + 1
+ !$omp end target
+
+ !$omp target exit data map(from: obj)
+
+ if (.not. same_child) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (.not. extends_child) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (.not. child_extends_obj) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (obj%base_value /= 9) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ print *, "======= Test Passed! ======="
+end program main
+
+! CHECK: ======= Test Passed! =======
diff --git a/offload/test/offloading/fortran/target-map-polymorphic-abstract-type-bound-dispatch.f90 b/offload/test/offloading/fortran/target-map-polymorphic-abstract-type-bound-dispatch.f90
new file mode 100644
index 00000000000000..89745663820850
--- /dev/null
+++ b/offload/test/offloading/fortran/target-map-polymorphic-abstract-type-bound-dispatch.f90
@@ -0,0 +1,128 @@
+! Offload test for dynamic dispatch through a mapped polymorphic descriptor
+! whose declared type is abstract and whose binding is deferred.
+!
+! This verifies that device dispatch does not need a concrete implementation on
+! the static abstract type. Instead, the mapped descriptor's device RTTI must
+! identify the concrete dynamic type and route the deferred binding call to that
+! concrete type's device procedure.
+!
+! REQUIRES: flang, amdgpu
+!
+! RUN: %libomptarget-compile-fortran-generic -fopenmp-version=61 && %libomptarget-run-generic | %fcheck-generic
+
+module polymorphic_abstract_type_bound_dispatch_mod
+ implicit none
+
+ type, abstract :: shape_t
+ integer :: bias
+ contains
+ procedure(value_iface), deferred :: value
+ procedure(update_iface), deferred :: update
+ end type shape_t
+
+ abstract interface
+ integer function value_iface(self, scale)
+ import :: shape_t
+ class(shape_t), intent(in) :: self
+ integer, intent(in) :: scale
+ end function value_iface
+
+ subroutine update_iface(self, amount)
+ import :: shape_t
+ class(shape_t), intent(inout) :: self
+ integer, intent(in) :: amount
+ end subroutine update_iface
+ end interface
+
+ type, extends(shape_t) :: rectangle_t
+ integer :: width
+ integer :: height
+ contains
+ procedure :: value => rectangle_value
+ procedure :: update => rectangle_update
+ end type rectangle_t
+
+contains
+
+ integer function rectangle_value(self, scale)
+ class(rectangle_t), intent(in) :: self
+ integer, intent(in) :: scale
+ rectangle_value = (self%width * self%height + self%bias) * scale
+ end function rectangle_value
+
+ subroutine rectangle_update(self, amount)
+ class(rectangle_t), intent(inout) :: self
+ integer, intent(in) :: amount
+ self%bias = self%bias + amount
+ self%width = self%width + 1
+ self%height = self%height + 2
+ end subroutine rectangle_update
+
+end module polymorphic_abstract_type_bound_dispatch_mod
+
+program main
+ use polymorphic_abstract_type_bound_dispatch_mod
+ implicit none
+
+ class(shape_t), allocatable :: obj
+ integer :: before
+ integer :: after
+
+ allocate(rectangle_t :: obj)
+ obj%bias = 1
+
+ select type (obj)
+ type is (rectangle_t)
+ obj%width = 4
+ obj%height = 5
+ class default
+ print *, "======= Test Failed! ======="
+ stop 1
+ end select
+
+ before = -1
+ after = -1
+
+ !$omp target enter data map(to: obj)
+
+ !$omp target map(tofrom: obj, before, after)
+ before = obj%value(2)
+ call obj%update(3)
+ after = obj%value(1)
+ !$omp end target
+
+ !$omp target exit data map(from: obj)
+
+ if (before /= 42) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (after /= 39) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ select type (obj)
+ type is (rectangle_t)
+ if (obj%bias /= 4) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+ if (obj%width /= 5) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+ if (obj%height /= 7) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+ class default
+ print *, "======= Test Failed! ======="
+ stop 1
+ end select
+
+ print *, "======= Test Passed! ======="
+end program main
+
+! CHECK: ======= Test Passed! =======
diff --git a/offload/test/offloading/fortran/target-map-polymorphic-array-rtti.f90 b/offload/test/offloading/fortran/target-map-polymorphic-array-rtti.f90
new file mode 100644
index 00000000000000..651d5d5bd6577f
--- /dev/null
+++ b/offload/test/offloading/fortran/target-map-polymorphic-array-rtti.f90
@@ -0,0 +1,66 @@
+! Offload test for polymorphic Fortran array descriptor RTTI without
+! SELECT TYPE in the target region.
+!
+! This exercises the array descriptor path while using EXTENDS_TYPE_OF on a
+! polymorphic array element to validate derived-type RTTI on device.
+!
+! REQUIRES: flang, amdgpu
+!
+! RUN: %libomptarget-compile-fortran-generic -fopenmp-version=61 && %libomptarget-run-generic | %fcheck-generic
+
+module polymorphic_array_rtti_mod
+ implicit none
+
+ type :: base_t
+ integer :: base_value
+ end type base_t
+
+ type, extends(base_t) :: child_t
+ integer :: child_value
+ end type child_t
+
+end module polymorphic_array_rtti_mod
+
+program main
+ use polymorphic_array_rtti_mod
+ implicit none
+
+ class(base_t), allocatable :: arr(:)
+ type(base_t) :: base_mold
+ logical :: extends_base
+ logical :: base_extends_elem
+
+ allocate(child_t :: arr(1))
+ arr(1)%base_value = 3
+
+ extends_base = .false.
+ base_extends_elem = .true.
+
+ !$omp target enter data map(to: arr)
+
+ !$omp target map(tofrom: arr, extends_base, base_extends_elem) map(to: base_mold)
+ extends_base = extends_type_of(arr(1), base_mold)
+ base_extends_elem = extends_type_of(base_mold, arr(1))
+ arr(1)%base_value = arr(1)%base_value + 10
+ !$omp end target
+
+ !$omp target exit data map(from: arr)
+
+ if (.not. extends_base) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (base_extends_elem) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (arr(1)%base_value /= 13) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+ print *, "======= Test Passed! ======="
+end program main
+
+! CHECK: ======= Test Passed! =======
diff --git a/offload/test/offloading/fortran/target-map-polymorphic-array-section-type-bound-dispatch.f90 b/offload/test/offloading/fortran/target-map-polymorphic-array-section-type-bound-dispatch.f90
new file mode 100644
index 00000000000000..97a292ddb10840
--- /dev/null
+++ b/offload/test/offloading/fortran/target-map-polymorphic-array-section-type-bound-dispatch.f90
@@ -0,0 +1,160 @@
+! Offload test for dynamic dispatch through mapped polymorphic array
+! descriptor sections.
+!
+! This verifies that an array section of a polymorphic array can be mapped,
+! that the descriptor base-address attach offset is computed correctly for the
+! section lower bound, and that extended dynamic-type components in the mapped
+! section are copied to and from the device.
+!
+! REQUIRES: flang, amdgpu
+!
+! RUN: %libomptarget-compile-fortran-generic -fopenmp-version=61 && %libomptarget-run-generic | %fcheck-generic
+
+module polymorphic_array_section_type_bound_dispatch_mod
+ implicit none
+
+ type :: base_t
+ integer :: base_value
+ contains
+ procedure :: value => base_value_fn
+ procedure :: adjust => base_adjust
+ end type base_t
+
+ type, extends(base_t) :: child_a_t
+ integer :: a_value
+ contains
+ procedure :: value => child_a_value_fn
+ procedure :: adjust => child_a_adjust
+ end type child_a_t
+
+ type, extends(base_t) :: child_b_t
+ integer :: b_value
+ contains
+ procedure :: value => child_b_value_fn
+ procedure :: adjust => child_b_adjust
+ end type child_b_t
+
+contains
+
+ integer function base_value_fn(self)
+ class(base_t), intent(in) :: self
+ base_value_fn = self%base_value
+ end function base_value_fn
+
+ subroutine base_adjust(self, amount)
+ class(base_t), intent(inout) :: self
+ integer, intent(in) :: amount
+ self%base_value = self%base_value + amount
+ end subroutine base_adjust
+
+ integer function child_a_value_fn(self)
+ class(child_a_t), intent(in) :: self
+ child_a_value_fn = self%base_value + self%a_value * 10
+ end function child_a_value_fn
+
+ subroutine child_a_adjust(self, amount)
+ class(child_a_t), intent(inout) :: self
+ integer, intent(in) :: amount
+ self%base_value = self%base_value + amount
+ self%a_value = self%a_value + 1
+ end subroutine child_a_adjust
+
+ integer function child_b_value_fn(self)
+ class(child_b_t), intent(in) :: self
+ child_b_value_fn = self%base_value + self%b_value * 100
+ end function child_b_value_fn
+
+ subroutine child_b_adjust(self, amount)
+ class(child_b_t), intent(inout) :: self
+ integer, intent(in) :: amount
+ self%base_value = self%base_value + amount * 2
+ self%b_value = self%b_value + 2
+ end subroutine child_b_adjust
+
+end module polymorphic_array_section_type_bound_dispatch_mod
+
+program main
+ use polymorphic_array_section_type_bound_dispatch_mod
+ implicit none
+
+ class(base_t), allocatable :: a_arr(:)
+ class(base_t), allocatable :: b_arr(:)
+ integer :: result_a
+ integer :: result_b
+ logical :: failed
+
+ allocate(child_a_t :: a_arr(10))
+ allocate(child_b_t :: b_arr(10))
+
+ a_arr(:)%base_value = -100
+ b_arr(:)%base_value = -200
+
+ a_arr(4)%base_value = 5
+ a_arr(10)%base_value = 11
+ select type (a_arr)
+ type is (child_a_t)
+ a_arr(:)%a_value = -10
+ a_arr(4)%a_value = 3
+ a_arr(10)%a_value = 6
+ class default
+ print *, "======= Test Failed! ======="
+ stop 1
+ end select
+
+ b_arr(4)%base_value = 7
+ b_arr(10)%base_value = 13
+ select type (b_arr)
+ type is (child_b_t)
+ b_arr(:)%b_value = -20
+ b_arr(4)%b_value = 2
+ b_arr(10)%b_value = 5
+ class default
+ print *, "======= Test Failed! ======="
+ stop 1
+ end select
+
+ result_a = -1
+ result_b = -1
+
+ !$omp target map(tofrom: a_arr(4:10), result_a)
+ result_a = a_arr(4)%value()
+ call a_arr(10)%adjust(4)
+ !$omp end target
+
+ !$omp target map(tofrom: b_arr(4:10), result_b)
+ result_b = b_arr(4)%value()
+ call b_arr(10)%adjust(4)
+ !$omp end target
+
+ failed = .false.
+
+ if (result_a /= 35) failed = .true.
+ if (result_b /= 207) failed = .true.
+
+ if (a_arr(10)%base_value /= 15) failed = .true.
+ select type (a_arr)
+ type is (child_a_t)
+ if (a_arr(10)%a_value /= 7) failed = .true.
+ if (a_arr(3)%a_value /= -10) failed = .true.
+ class default
+ failed = .true.
+ end select
+
+ if (b_arr(10)%base_value /= 21) failed = .true.
+ select type (b_arr)
+ type is (child_b_t)
+ if (b_arr(10)%b_value /= 7) failed = .true.
+ if (b_arr(3)%b_value /= -20) failed = .true.
+ class default
+ failed = .true.
+ end select
+
+ if (failed) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ print *, "======= Test Passed! ======="
+end program main
+
+! CHECK: ======= Test Passed! =======
diff --git a/offload/test/offloading/fortran/target-map-polymorphic-array-type-bound-dispatch.f90 b/offload/test/offloading/fortran/target-map-polymorphic-array-type-bound-dispatch.f90
new file mode 100644
index 00000000000000..14f52f389a4bb9
--- /dev/null
+++ b/offload/test/offloading/fortran/target-map-polymorphic-array-type-bound-dispatch.f90
@@ -0,0 +1,156 @@
+! Offload test for dynamic dispatch through mapped polymorphic array
+! descriptors.
+!
+! This is the array analogue of the polymorphic class-pointer type-bound
+! dispatch test. It verifies that dispatch follows the dynamic element type and
+! that extended dynamic-type components are copied to and from the device for
+! polymorphic arrays.
+!
+! This verifies that polymorphic array descriptor maps use runtime elem_len
+! rather than the declared element type size when copying array elements.
+!
+! REQUIRES: flang, amdgpu
+!
+! RUN: %libomptarget-compile-fortran-generic -fopenmp-version=61 && %libomptarget-run-generic | %fcheck-generic
+
+module polymorphic_array_type_bound_dispatch_mod
+ implicit none
+
+ type :: base_t
+ integer :: base_value
+ contains
+ procedure :: value => base_value_fn
+ procedure :: adjust => base_adjust
+ end type base_t
+
+ type, extends(base_t) :: child_a_t
+ integer :: a_value
+ contains
+ procedure :: value => child_a_value_fn
+ procedure :: adjust => child_a_adjust
+ end type child_a_t
+
+ type, extends(base_t) :: child_b_t
+ integer :: b_value
+ contains
+ procedure :: value => child_b_value_fn
+ procedure :: adjust => child_b_adjust
+ end type child_b_t
+
+contains
+
+ integer function base_value_fn(self)
+ class(base_t), intent(in) :: self
+ base_value_fn = self%base_value
+ end function base_value_fn
+
+ subroutine base_adjust(self, amount)
+ class(base_t), intent(inout) :: self
+ integer, intent(in) :: amount
+ self%base_value = self%base_value + amount
+ end subroutine base_adjust
+
+ integer function child_a_value_fn(self)
+ class(child_a_t), intent(in) :: self
+ child_a_value_fn = self%base_value + self%a_value * 10
+ end function child_a_value_fn
+
+ subroutine child_a_adjust(self, amount)
+ class(child_a_t), intent(inout) :: self
+ integer, intent(in) :: amount
+ self%base_value = self%base_value + amount
+ self%a_value = self%a_value + 1
+ end subroutine child_a_adjust
+
+ integer function child_b_value_fn(self)
+ class(child_b_t), intent(in) :: self
+ child_b_value_fn = self%base_value + self%b_value * 100
+ end function child_b_value_fn
+
+ subroutine child_b_adjust(self, amount)
+ class(child_b_t), intent(inout) :: self
+ integer, intent(in) :: amount
+ self%base_value = self%base_value + amount * 2
+ self%b_value = self%b_value + 2
+ end subroutine child_b_adjust
+
+end module polymorphic_array_type_bound_dispatch_mod
+
+program main
+ use polymorphic_array_type_bound_dispatch_mod
+ implicit none
+
+ class(base_t), allocatable :: a_arr(:)
+ class(base_t), allocatable :: b_arr(:)
+ integer :: result_a
+ integer :: result_b
+ logical :: failed
+
+ allocate(child_a_t :: a_arr(2))
+ allocate(child_b_t :: b_arr(2))
+
+ a_arr(1)%base_value = 5
+ a_arr(2)%base_value = 11
+ select type (a_arr)
+ type is (child_a_t)
+ a_arr(1)%a_value = 3
+ a_arr(2)%a_value = 6
+ class default
+ print *, "======= Test Failed! ======="
+ stop 1
+ end select
+
+ b_arr(1)%base_value = 7
+ b_arr(2)%base_value = 13
+ select type (b_arr)
+ type is (child_b_t)
+ b_arr(1)%b_value = 2
+ b_arr(2)%b_value = 5
+ class default
+ print *, "======= Test Failed! ======="
+ stop 1
+ end select
+
+ result_a = -1
+ result_b = -1
+
+ !$omp target map(tofrom: a_arr, result_a)
+ result_a = a_arr(1)%value()
+ call a_arr(2)%adjust(4)
+ !$omp end target
+
+ !$omp target map(tofrom: b_arr, result_b)
+ result_b = b_arr(1)%value()
+ call b_arr(2)%adjust(4)
+ !$omp end target
+
+ failed = .false.
+
+ if (result_a /= 35) failed = .true.
+ if (result_b /= 207) failed = .true.
+
+ if (a_arr(2)%base_value /= 15) failed = .true.
+ select type (a_arr)
+ type is (child_a_t)
+ if (a_arr(2)%a_value /= 7) failed = .true.
+ class default
+ failed = .true.
+ end select
+
+ if (b_arr(2)%base_value /= 21) failed = .true.
+ select type (b_arr)
+ type is (child_b_t)
+ if (b_arr(2)%b_value /= 7) failed = .true.
+ class default
+ failed = .true.
+ end select
+
+ if (failed) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ print *, "======= Test Passed! ======="
+end program main
+
+! CHECK: ======= Test Passed! =======
diff --git a/offload/test/offloading/fortran/target-map-polymorphic-derived-type.f90 b/offload/test/offloading/fortran/target-map-polymorphic-derived-type.f90
new file mode 100644
index 00000000000000..68be4c17fac769
--- /dev/null
+++ b/offload/test/offloading/fortran/target-map-polymorphic-derived-type.f90
@@ -0,0 +1,139 @@
+! Offload test for mapping a polymorphic Fortran derived type whose dynamic
+! type extends its declared type.
+!
+! The initial target enter data map is performed while the selector has the
+! extended dynamic type. Later target regions use the original base-class
+! polymorphic variable in map clauses. This follows the OpenMP rule that a
+! polymorphic list item whose dynamic type differs from its declared type must
+! already have a corresponding list item in the device data environment when it
+! is encountered by a map-entering construct.
+!
+! REQUIRES: flang, amdgpu
+!
+! RUN: %libomptarget-compile-fortran-generic -fopenmp-version=61 && %libomptarget-run-generic | %fcheck-generic
+
+module polymorphic_map_mod
+ implicit none
+
+ type :: base_t
+ integer :: base_value
+ integer :: base_array(4)
+ end type base_t
+
+ type, extends(base_t) :: child_t
+ integer :: child_value
+ integer :: child_array(4)
+ end type child_t
+
+contains
+
+ subroutine init_child(obj)
+ class(base_t), allocatable, intent(out) :: obj
+ integer :: i
+
+ allocate(child_t :: obj)
+
+ select type (obj)
+ type is (child_t)
+ obj%base_value = 10
+ obj%child_value = 20
+ do i = 1, 4
+ obj%base_array(i) = i
+ obj%child_array(i) = 10 * i
+ end do
+ end select
+ end subroutine init_child
+
+end module polymorphic_map_mod
+
+program main
+ use polymorphic_map_mod
+ implicit none
+
+ class(base_t), allocatable :: obj
+ integer :: i
+ logical :: logic
+
+ call init_child(obj)
+
+ logic = .false.
+
+ ! Map the full dynamic object. The list item in later regions is the
+ ! base-class polymorphic variable, which requires the corresponding dynamic
+ ! type allocation to already exist in the device data environment.
+ select type (obj)
+ type is (child_t)
+ !$omp target enter data map(to: obj)
+ class default
+ print *, "======= Test Failed! ======="
+ stop 1
+ end select
+
+ ! Verify that the dynamic type is preserved and that the extended components
+ ! can also be accessed after mapping the base-class polymorphic list item.
+ !$omp target map(tofrom: logic)
+ obj%base_value = obj%base_value + 1
+ do i = 1, 4
+ obj%base_array(i) = obj%base_array(i) + 1
+ end do
+
+ select type (obj)
+ type is (child_t)
+ logic = .true.
+ obj%child_value = obj%child_value + obj%base_value
+ do i = 1, 4
+ obj%child_array(i) = obj%child_array(i) + obj%base_array(i)
+ end do
+ class default
+ obj%base_value = -999
+ end select
+ !$omp end target
+
+ ! Copy the full dynamic object back.
+ select type (obj)
+ type is (child_t)
+ !$omp target exit data map(from: obj)
+ class default
+ print *, "======= Test Failed! ======="
+ stop 1
+ end select
+
+ if (.not. logic) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (obj%base_value /= 11) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ do i = 1, 4
+ if (obj%base_array(i) /= i + 1) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+ end do
+
+ select type (obj)
+ type is (child_t)
+ if (obj%child_value /= 31) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ do i = 1, 4
+ if (obj%child_array(i) /= 10 * i + i + 1) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+ end do
+ class default
+ print *, "======= Test Failed! ======="
+ stop 1
+ end select
+
+ print *, "======= Test Passed! ======="
+end program main
+
+! CHECK: ======= Test Passed! =======
diff --git a/offload/test/offloading/fortran/target-map-polymorphic-multilevel-type-bound-dispatch.f90 b/offload/test/offloading/fortran/target-map-polymorphic-multilevel-type-bound-dispatch.f90
new file mode 100644
index 00000000000000..3341e4d5d7872e
--- /dev/null
+++ b/offload/test/offloading/fortran/target-map-polymorphic-multilevel-type-bound-dispatch.f90
@@ -0,0 +1,156 @@
+! Offload test for dynamic dispatch through a mapped polymorphic descriptor
+! with multiple levels of type extension.
+!
+! This verifies that the device RTTI binding table for the most-derived dynamic
+! type is used when dispatching through a base-class descriptor, including both
+! function and subroutine type-bound procedures.
+!
+! REQUIRES: flang, amdgpu
+!
+! RUN: %libomptarget-compile-fortran-generic -fopenmp-version=61 && %libomptarget-run-generic | %fcheck-generic
+
+module polymorphic_multilevel_type_bound_dispatch_mod
+ implicit none
+
+ type :: base_t
+ integer :: base_value
+ contains
+ procedure :: value => base_value_fn
+ procedure :: bump => base_bump
+ end type base_t
+
+ type, extends(base_t) :: middle_t
+ integer :: middle_value
+ contains
+ procedure :: value => middle_value_fn
+ procedure :: bump => middle_bump
+ end type middle_t
+
+ type, extends(middle_t) :: leaf_t
+ integer :: leaf_value
+ contains
+ procedure :: value => leaf_value_fn
+ procedure :: bump => leaf_bump
+ end type leaf_t
+
+contains
+
+ integer function base_value_fn(self, scale)
+ class(base_t), intent(in) :: self
+ integer, intent(in) :: scale
+ base_value_fn = self%base_value * scale
+ end function base_value_fn
+
+ subroutine base_bump(self, amount)
+ class(base_t), intent(inout) :: self
+ integer, intent(in) :: amount
+ self%base_value = self%base_value + amount
+ end subroutine base_bump
+
+ integer function middle_value_fn(self, scale)
+ class(middle_t), intent(in) :: self
+ integer, intent(in) :: scale
+ middle_value_fn = (self%base_value + self%middle_value) * scale
+ end function middle_value_fn
+
+ subroutine middle_bump(self, amount)
+ class(middle_t), intent(inout) :: self
+ integer, intent(in) :: amount
+ self%base_value = self%base_value + amount
+ self%middle_value = self%middle_value + amount * 2
+ end subroutine middle_bump
+
+ integer function leaf_value_fn(self, scale)
+ class(leaf_t), intent(in) :: self
+ integer, intent(in) :: scale
+ leaf_value_fn = (self%base_value + self%middle_value + self%leaf_value) * scale
+ end function leaf_value_fn
+
+ subroutine leaf_bump(self, amount)
+ class(leaf_t), intent(inout) :: self
+ integer, intent(in) :: amount
+ self%base_value = self%base_value + amount
+ self%middle_value = self%middle_value + amount * 2
+ self%leaf_value = self%leaf_value + amount * 3
+ end subroutine leaf_bump
+
+end module polymorphic_multilevel_type_bound_dispatch_mod
+
+program main
+ use polymorphic_multilevel_type_bound_dispatch_mod
+ implicit none
+
+ class(base_t), allocatable :: obj
+ integer :: before
+ integer :: after
+
+ allocate(leaf_t :: obj)
+ obj%base_value = 2
+
+ select type (obj)
+ type is (leaf_t)
+ obj%middle_value = 3
+ obj%leaf_value = 5
+ class default
+ print *, "======= Test Failed! ======="
+ stop 1
+ end select
+
+ before = -1
+ after = -1
+
+ select type (obj)
+ type is (leaf_t)
+ !$omp target enter data map(to: obj)
+ class default
+ print *, "======= Test Failed! ======="
+ stop 1
+ end select
+
+ !$omp target map(tofrom: obj, before, after)
+ before = obj%value(4)
+ call obj%bump(2)
+ after = obj%value(1)
+ !$omp end target
+
+ select type (obj)
+ type is (leaf_t)
+ !$omp target exit data map(from: obj)
+ class default
+ print *, "======= Test Failed! ======="
+ stop 1
+ end select
+
+ if (before /= 40) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (after /= 22) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ select type (obj)
+ type is (leaf_t)
+ if (obj%base_value /= 4) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+ if (obj%middle_value /= 7) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+ if (obj%leaf_value /= 11) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+ class default
+ print *, "======= Test Failed! ======="
+ stop 1
+ end select
+
+ print *, "======= Test Passed! ======="
+end program main
+
+! CHECK: ======= Test Passed! =======
diff --git a/offload/test/offloading/fortran/target-map-polymorphic-nested-rtti.f90 b/offload/test/offloading/fortran/target-map-polymorphic-nested-rtti.f90
new file mode 100644
index 00000000000000..3423126f0d17a6
--- /dev/null
+++ b/offload/test/offloading/fortran/target-map-polymorphic-nested-rtti.f90
@@ -0,0 +1,82 @@
+! Offload test for a polymorphic descriptor nested inside a derived type.
+!
+! This verifies that descriptor addendum RTTI handling still works when the
+! descriptor is a derived-type component instead of the top-level map item.
+!
+! REQUIRES: flang, amdgpu
+!
+! RUN: %libomptarget-compile-fortran-generic -fopenmp-version=61 && %libomptarget-run-generic | %fcheck-generic
+
+module polymorphic_nested_rtti_mod
+ implicit none
+
+ type :: base_t
+ integer :: base_value
+ end type base_t
+
+ type, extends(base_t) :: child_t
+ integer :: child_value
+ end type child_t
+
+ type :: wrapper_t
+ integer :: marker
+ class(base_t), allocatable :: item
+ end type wrapper_t
+
+contains
+
+ subroutine init_wrapper(w)
+ type(wrapper_t), intent(out) :: w
+
+ w%marker = 5
+ allocate(child_t :: w%item)
+ w%item%base_value = 12
+ end subroutine init_wrapper
+
+end module polymorphic_nested_rtti_mod
+
+program main
+ use polymorphic_nested_rtti_mod
+ implicit none
+
+ type(wrapper_t) :: w
+ type(base_t) :: base_mold
+ logical :: extends_base
+ logical :: base_extends_item
+
+ call init_wrapper(w)
+
+ extends_base = .false.
+ base_extends_item = .true.
+
+ !$omp target map(tofrom: w, extends_base, base_extends_item) map(to: base_mold)
+ extends_base = extends_type_of(w%item, base_mold)
+ base_extends_item = extends_type_of(base_mold, w%item)
+ w%marker = w%marker + 1
+ w%item%base_value = w%item%base_value + 1
+ !$omp end target
+
+ if (.not. extends_base) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (base_extends_item) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (w%marker /= 6) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (w%item%base_value /= 13) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ print *, "======= Test Passed! ======="
+end program main
+
+! CHECK: ======= Test Passed! =======
diff --git a/offload/test/offloading/fortran/target-map-polymorphic-pointer-rtti.f90 b/offload/test/offloading/fortran/target-map-polymorphic-pointer-rtti.f90
new file mode 100644
index 00000000000000..ae6007a6b5d077
--- /dev/null
+++ b/offload/test/offloading/fortran/target-map-polymorphic-pointer-rtti.f90
@@ -0,0 +1,71 @@
+! Offload test for polymorphic Fortran pointer descriptor RTTI without
+! SELECT TYPE in the target region.
+!
+! This uses EXTENDS_TYPE_OF on device to verify that a polymorphic pointer
+! descriptor's addendum derived_type pointer is attached to the canonical device
+! TypeDescriptor global.
+!
+! REQUIRES: flang, amdgpu
+!
+! RUN: %libomptarget-compile-fortran-generic -fopenmp-version=61 && %libomptarget-run-generic | %fcheck-generic
+
+module polymorphic_pointer_rtti_mod
+ implicit none
+
+ type :: base_t
+ integer :: base_value
+ end type base_t
+
+ type, extends(base_t) :: child_t
+ integer :: child_value
+ end type child_t
+
+end module polymorphic_pointer_rtti_mod
+
+program main
+ use polymorphic_pointer_rtti_mod
+ implicit none
+
+ type(child_t), target :: target_obj
+ class(base_t), pointer :: obj
+ type(base_t) :: base_mold
+ logical :: extends_base
+ logical :: base_extends_obj
+
+ target_obj%base_value = 41
+ target_obj%child_value = 7
+ obj => target_obj
+
+ extends_base = .false.
+ base_extends_obj = .true.
+
+ !$omp target map(tofrom: obj, extends_base, base_extends_obj) map(to: base_mold)
+ extends_base = extends_type_of(obj, base_mold)
+ base_extends_obj = extends_type_of(base_mold, obj)
+ obj%base_value = obj%base_value + 1
+ !$omp end target
+
+ if (.not. extends_base) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (base_extends_obj) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (target_obj%base_value /= 42) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (target_obj%child_value /= 7) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ print *, "======= Test Passed! ======="
+end program main
+
+! CHECK: ======= Test Passed! =======
diff --git a/offload/test/offloading/fortran/target-map-polymorphic-pointer-type-bound-dispatch.f90 b/offload/test/offloading/fortran/target-map-polymorphic-pointer-type-bound-dispatch.f90
new file mode 100644
index 00000000000000..a98c312d1c93de
--- /dev/null
+++ b/offload/test/offloading/fortran/target-map-polymorphic-pointer-type-bound-dispatch.f90
@@ -0,0 +1,138 @@
+! Offload test for dynamic dispatch through a mapped polymorphic pointer
+! descriptor.
+!
+! This verifies that a class pointer descriptor's derived_type addendum is
+! attached to the canonical device RTTI global, and that dispatch follows the
+! pointer's current dynamic type across separate target regions.
+!
+! REQUIRES: flang, amdgpu
+!
+! RUN: %libomptarget-compile-fortran-generic -fopenmp-version=61 && %libomptarget-run-generic | %fcheck-generic
+
+module polymorphic_pointer_type_bound_dispatch_mod
+ implicit none
+
+ type :: base_t
+ integer :: base_value
+ contains
+ procedure :: value => base_value_fn
+ procedure :: adjust => base_adjust
+ end type base_t
+
+ type, extends(base_t) :: child_a_t
+ integer :: a_value
+ contains
+ procedure :: value => child_a_value_fn
+ procedure :: adjust => child_a_adjust
+ end type child_a_t
+
+ type, extends(base_t) :: child_b_t
+ integer :: b_value
+ contains
+ procedure :: value => child_b_value_fn
+ procedure :: adjust => child_b_adjust
+ end type child_b_t
+
+contains
+
+ integer function base_value_fn(self)
+ class(base_t), intent(in) :: self
+ base_value_fn = self%base_value
+ end function base_value_fn
+
+ subroutine base_adjust(self, amount)
+ class(base_t), intent(inout) :: self
+ integer, intent(in) :: amount
+ self%base_value = self%base_value + amount
+ end subroutine base_adjust
+
+ integer function child_a_value_fn(self)
+ class(child_a_t), intent(in) :: self
+ child_a_value_fn = self%base_value + self%a_value * 10
+ end function child_a_value_fn
+
+ subroutine child_a_adjust(self, amount)
+ class(child_a_t), intent(inout) :: self
+ integer, intent(in) :: amount
+ self%base_value = self%base_value + amount
+ self%a_value = self%a_value + 1
+ end subroutine child_a_adjust
+
+ integer function child_b_value_fn(self)
+ class(child_b_t), intent(in) :: self
+ child_b_value_fn = self%base_value + self%b_value * 100
+ end function child_b_value_fn
+
+ subroutine child_b_adjust(self, amount)
+ class(child_b_t), intent(inout) :: self
+ integer, intent(in) :: amount
+ self%base_value = self%base_value + amount * 2
+ self%b_value = self%b_value + 2
+ end subroutine child_b_adjust
+
+end module polymorphic_pointer_type_bound_dispatch_mod
+
+program main
+ use polymorphic_pointer_type_bound_dispatch_mod
+ implicit none
+
+ type(child_a_t), target :: a_obj
+ type(child_b_t), target :: b_obj
+ class(base_t), pointer :: obj
+ integer :: result_a
+ integer :: result_b
+
+ a_obj%base_value = 5
+ a_obj%a_value = 3
+ b_obj%base_value = 7
+ b_obj%b_value = 2
+
+ result_a = -1
+ result_b = -1
+
+ obj => a_obj
+ !$omp target map(tofrom: obj, result_a)
+ result_a = obj%value()
+ call obj%adjust(4)
+ !$omp end target
+
+ obj => b_obj
+ !$omp target map(tofrom: obj, result_b)
+ result_b = obj%value()
+ call obj%adjust(4)
+ !$omp end target
+
+ if (result_a /= 35) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (result_b /= 207) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (a_obj%base_value /= 9) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (a_obj%a_value /= 4) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (b_obj%base_value /= 15) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (b_obj%b_value /= 4) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ print *, "======= Test Passed! ======="
+end program main
+
+! CHECK: ======= Test Passed! =======
diff --git a/offload/test/offloading/fortran/target-map-polymorphic-remap-rtti.f90 b/offload/test/offloading/fortran/target-map-polymorphic-remap-rtti.f90
new file mode 100644
index 00000000000000..183987093d57b7
--- /dev/null
+++ b/offload/test/offloading/fortran/target-map-polymorphic-remap-rtti.f90
@@ -0,0 +1,112 @@
+! Offload test for remapping a polymorphic descriptor after its dynamic
+! type changes.
+!
+! The test maps a child1_t object, deletes it from the device data
+! environment, reallocates the polymorphic variable as child2_t, and maps it
+! again. The target regions use SAME_TYPE_AS to verify that the descriptor
+! addendum/RTTI for the second mapping is not stale.
+!
+! REQUIRES: flang, amdgpu
+!
+! RUN: %libomptarget-compile-fortran-generic -fopenmp-version=61 && %libomptarget-run-generic | %fcheck-generic
+
+module polymorphic_remap_rtti_mod
+ implicit none
+
+ type :: base_t
+ integer :: base_value
+ end type base_t
+
+ type, extends(base_t) :: child1_t
+ integer :: child1_value
+ end type child1_t
+
+ type, extends(base_t) :: child2_t
+ integer :: child2_value
+ end type child2_t
+
+end module polymorphic_remap_rtti_mod
+
+program main
+ use polymorphic_remap_rtti_mod
+ implicit none
+
+ class(base_t), allocatable :: obj
+ type(child1_t) :: child1_mold
+ type(child2_t) :: child2_mold
+ logical :: first_is_child1
+ logical :: first_is_child2
+ logical :: second_is_child1
+ logical :: second_is_child2
+
+ allocate(child1_t :: obj)
+ obj%base_value = 1
+
+ select type (obj)
+ type is (child1_t)
+ obj%child1_value = 10
+ class default
+ print *, "======= Test Failed! ======="
+ stop 1
+ end select
+
+ first_is_child1 = .false.
+ first_is_child2 = .true.
+
+ !$omp target enter data map(to: obj)
+
+ !$omp target map(tofrom: obj, first_is_child1, first_is_child2) map(to: child1_mold, child2_mold)
+ first_is_child1 = same_type_as(obj, child1_mold)
+ first_is_child2 = same_type_as(obj, child2_mold)
+ !$omp end target
+
+ !$omp target exit data map(delete: obj)
+
+ if (.not. first_is_child1) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (first_is_child2) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ deallocate(obj)
+ allocate(child2_t :: obj)
+ obj%base_value = 2
+
+ select type (obj)
+ type is (child2_t)
+ obj%child2_value = 20
+ class default
+ print *, "======= Test Failed! ======="
+ stop 1
+ end select
+
+ second_is_child1 = .true.
+ second_is_child2 = .false.
+
+ !$omp target enter data map(to: obj)
+
+ !$omp target map(tofrom: obj, second_is_child1, second_is_child2) map(to: child1_mold, child2_mold)
+ second_is_child1 = same_type_as(obj, child1_mold)
+ second_is_child2 = same_type_as(obj, child2_mold)
+ !$omp end target
+
+ !$omp target exit data map(delete: obj)
+
+ if (second_is_child1) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (.not. second_is_child2) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ print *, "======= Test Passed! ======="
+end program main
+
+! CHECK: ======= Test Passed! =======
diff --git a/offload/test/offloading/fortran/target-map-polymorphic-rtti-intrinsics.f90 b/offload/test/offloading/fortran/target-map-polymorphic-rtti-intrinsics.f90
new file mode 100644
index 00000000000000..7836db4510b81e
--- /dev/null
+++ b/offload/test/offloading/fortran/target-map-polymorphic-rtti-intrinsics.f90
@@ -0,0 +1,112 @@
+! Offload test for polymorphic Fortran descriptor RTTI without SELECT TYPE.
+!
+! This uses EXTENDS_TYPE_OF on device to verify that the descriptor addendum's
+! derived_type pointer is attached to the canonical device TypeDescriptor
+! global. The test avoids SELECT TYPE in the target regions.
+!
+! REQUIRES: flang, amdgpu
+!
+! RUN: %libomptarget-compile-fortran-generic -fopenmp-version=61 && %libomptarget-run-generic | %fcheck-generic
+
+module polymorphic_rtti_intrinsics_mod
+ implicit none
+
+ type :: base_t
+ integer :: base_value
+ end type base_t
+
+ type, extends(base_t) :: child_t
+ integer :: child_value
+ end type child_t
+
+contains
+
+ subroutine check_dummy_addendum(obj, extends_base, base_extends_obj)
+ class(base_t), intent(inout) :: obj
+ logical, intent(out) :: extends_base
+ logical, intent(out) :: base_extends_obj
+ type(base_t) :: base_mold
+
+ extends_base = .false.
+ base_extends_obj = .true.
+
+ !$omp target map(tofrom: obj, extends_base, base_extends_obj) map(to: base_mold)
+ extends_base = extends_type_of(obj, base_mold)
+ base_extends_obj = extends_type_of(base_mold, obj)
+ obj%base_value = obj%base_value + 1
+ !$omp end target
+ end subroutine check_dummy_addendum
+
+end module polymorphic_rtti_intrinsics_mod
+
+program main
+ use polymorphic_rtti_intrinsics_mod
+ implicit none
+
+ class(base_t), allocatable :: obj
+ type(base_t) :: base_mold
+ type(child_t) :: child_actual
+ logical :: extends_base
+ logical :: base_extends_child
+ logical :: dummy_extends_base
+ logical :: dummy_base_extends_obj
+
+ allocate(child_t :: obj)
+ obj%base_value = 10
+
+ extends_base = .false.
+ base_extends_child = .true.
+
+ !$omp target enter data map(to: obj)
+
+ !$omp target map(tofrom: obj, extends_base, base_extends_child) map(to: base_mold)
+ extends_base = extends_type_of(obj, base_mold)
+ base_extends_child = extends_type_of(base_mold, obj)
+ obj%base_value = obj%base_value + 1
+ !$omp end target
+
+ !$omp target exit data map(from: obj)
+
+ if (.not. extends_base) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (base_extends_child) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (obj%base_value /= 11) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ child_actual%base_value = 20
+ child_actual%child_value = 30
+ call check_dummy_addendum(child_actual, dummy_extends_base, dummy_base_extends_obj)
+
+ if (.not. dummy_extends_base) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (dummy_base_extends_obj) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (child_actual%base_value /= 21) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (child_actual%child_value /= 30) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ print *, "======= Test Passed! ======="
+end program main
+
+! CHECK: ======= Test Passed! =======
diff --git a/offload/test/offloading/fortran/target-map-polymorphic-same-type-as.f90 b/offload/test/offloading/fortran/target-map-polymorphic-same-type-as.f90
new file mode 100644
index 00000000000000..573af6fdd34288
--- /dev/null
+++ b/offload/test/offloading/fortran/target-map-polymorphic-same-type-as.f90
@@ -0,0 +1,93 @@
+! Offload test for SAME_TYPE_AS using mapped polymorphic Fortran
+! descriptors without SELECT TYPE in the target region.
+!
+! SAME_TYPE_AS is stricter than EXTENDS_TYPE_OF and requires exact dynamic type
+! identity for polymorphic descriptor RTTI on device.
+!
+! REQUIRES: flang, amdgpu
+!
+! RUN: %libomptarget-compile-fortran-generic -fopenmp-version=61 && %libomptarget-run-generic | %fcheck-generic
+
+module polymorphic_same_type_as_mod
+ implicit none
+
+ type :: base_t
+ integer :: base_value
+ end type base_t
+
+ type, extends(base_t) :: child_t
+ integer :: child_value
+ end type child_t
+
+end module polymorphic_same_type_as_mod
+
+program main
+ use polymorphic_same_type_as_mod
+ implicit none
+
+ class(base_t), allocatable :: a
+ class(base_t), allocatable :: b
+ type(base_t) :: base_mold
+ type(child_t) :: child_mold
+ logical :: same_self
+ logical :: same_other_child
+ logical :: same_base
+ logical :: same_child_mold
+
+ allocate(child_t :: a)
+ allocate(child_t :: b)
+ a%base_value = 1
+ b%base_value = 2
+
+ same_self = .false.
+ same_other_child = .false.
+ same_base = .true.
+ same_child_mold = .false.
+
+ !$omp target enter data map(to: a, b)
+
+ !$omp target map(tofrom: a, b, same_self, same_other_child, same_base, same_child_mold) map(to: base_mold, child_mold)
+ same_self = same_type_as(a, a)
+ same_other_child = same_type_as(a, b)
+ same_base = same_type_as(a, base_mold)
+ same_child_mold = same_type_as(a, child_mold)
+ a%base_value = a%base_value + 1
+ b%base_value = b%base_value + 1
+ !$omp end target
+
+ !$omp target exit data map(from: a, b)
+
+ if (.not. same_self) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (.not. same_other_child) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (same_base) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (.not. same_child_mold) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (a%base_value /= 2) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (b%base_value /= 3) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ print *, "======= Test Passed! ======="
+end program main
+
+! CHECK: ======= Test Passed! =======
diff --git a/offload/test/offloading/fortran/target-map-polymorphic-type-bound-dispatch.f90 b/offload/test/offloading/fortran/target-map-polymorphic-type-bound-dispatch.f90
new file mode 100644
index 00000000000000..572603c1fa1486
--- /dev/null
+++ b/offload/test/offloading/fortran/target-map-polymorphic-type-bound-dispatch.f90
@@ -0,0 +1,95 @@
+! Offload test for type-bound dispatch through a mapped polymorphic
+! descriptor.
+!
+! Dynamic dispatch exercises TypeDescriptor RTTI metadata beyond direct
+! derived_type identity, including the device-side binding table referenced
+! from the canonical TypeDescriptor global.
+!
+! REQUIRES: flang, amdgpu
+!
+! RUN: %libomptarget-compile-fortran-generic -fopenmp-version=61 && %libomptarget-run-generic | %fcheck-generic
+
+module polymorphic_type_bound_dispatch_mod
+ implicit none
+
+ type :: base_t
+ integer :: base_value
+ contains
+ procedure :: value => base_value_fn
+ end type base_t
+
+ type, extends(base_t) :: child_t
+ integer :: child_value
+ contains
+ procedure :: value => child_value_fn
+ end type child_t
+
+contains
+
+ integer function base_value_fn(self)
+ class(base_t), intent(in) :: self
+ base_value_fn = self%base_value
+ end function base_value_fn
+
+ integer function child_value_fn(self)
+ class(child_t), intent(in) :: self
+ child_value_fn = self%base_value + self%child_value
+ end function child_value_fn
+
+end module polymorphic_type_bound_dispatch_mod
+
+program main
+ use polymorphic_type_bound_dispatch_mod
+ implicit none
+
+ class(base_t), allocatable :: obj
+ integer :: result
+
+ allocate(child_t :: obj)
+ obj%base_value = 11
+
+ select type (obj)
+ type is (child_t)
+ obj%child_value = 31
+ class default
+ print *, "======= Test Failed! ======="
+ stop 1
+ end select
+
+ result = -1
+
+ select type (obj)
+ type is (child_t)
+ !$omp target enter data map(to: obj)
+ class default
+ print *, "======= Test Failed! ======="
+ stop 1
+ end select
+
+ !$omp target map(tofrom: obj, result)
+ result = obj%value()
+ obj%base_value = obj%base_value + 1
+ !$omp end target
+
+ select type (obj)
+ type is (child_t)
+ !$omp target exit data map(from: obj)
+ class default
+ print *, "======= Test Failed! ======="
+ stop 1
+ end select
+
+ if (result /= 42) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ if (obj%base_value /= 12) then
+ print *, "======= Test Failed! ======="
+ stop 1
+ end if
+
+ print *, "======= Test Passed! ======="
+end program main
+
+! CHECK: ======= Test Passed! =======
More information about the flang-commits
mailing list