[flang] Add special genre for allocatable and pointer device component

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

@@ -171,20 +171,21 @@ class Descriptor {
       void *p = nullptr, int rank = maxRank,
       const SubscriptValue *extent = nullptr,
       ISO::CFI_attribute_t attribute = CFI_attribute_other,
-      bool addendum = false);
+      bool addendum = false, int allocatorIdx = kDefaultAllocator);
   RT_API_ATTRS void Establish(TypeCategory, int kind, void *p = nullptr,
       int rank = maxRank, const SubscriptValue *extent = nullptr,
       ISO::CFI_attribute_t attribute = CFI_attribute_other,
-      bool addendum = false);
+      bool addendum = false, int allocatorIdx = kDefaultAllocator);
   RT_API_ATTRS void Establish(int characterKind, std::size_t characters,
       void *p = nullptr, int rank = maxRank,
       const SubscriptValue *extent = nullptr,
       ISO::CFI_attribute_t attribute = CFI_attribute_other,
-      bool addendum = false);
+      bool addendum = false, int allocatorIdx = kDefaultAllocator);
   RT_API_ATTRS void Establish(const typeInfo::DerivedType &dt,
       void *p = nullptr, int rank = maxRank,
       const SubscriptValue *extent = nullptr,
-      ISO::CFI_attribute_t attribute = CFI_attribute_other);
+      ISO::CFI_attribute_t attribute = CFI_attribute_other,
+      int allocatorIdx = kDefaultAllocator);
 
   RT_API_ATTRS void UncheckedScalarEstablish(
       const typeInfo::DerivedType &, void *);

flang-rt/include/flang-rt/runtime/type-info.h

@@ -55,7 +55,9 @@ class Component {
     Data = 1,
     Pointer = 2,
     Allocatable = 3,
-    Automatic = 4
+    Automatic = 4,
+    PointerDevice = 5,
+    AllocatableDevice = 6
   };
 
   RT_API_ATTRS const Descriptor &name() const { return name_.descriptor(); }

flang-rt/lib/runtime/assign.cpp

@@ -648,7 +648,8 @@ RT_API_ATTRS int DerivedAssignTicket<IS_COMPONENTWISE>::Continue(
         }
       }
       break;
-    case typeInfo::Component::Genre::Pointer: {
+    case typeInfo::Component::Genre::Pointer:
+    case typeInfo::Component::Genre::PointerDevice: {
       std::size_t componentByteSize{
           this->component_->SizeInBytes(this->instance_)};
       if (IS_COMPONENTWISE && toIsContiguous_ && fromIsContiguous_) {
@@ -680,6 +681,7 @@ RT_API_ATTRS int DerivedAssignTicket<IS_COMPONENTWISE>::Continue(
       }
     } break;
     case typeInfo::Component::Genre::Allocatable:
+    case typeInfo::Component::Genre::AllocatableDevice:
     case typeInfo::Component::Genre::Automatic: {
       auto *toDesc{reinterpret_cast<Descriptor *>(
           this->instance_.template Element<char>(this->subscripts_) +

flang-rt/lib/runtime/copy.cpp

@@ -168,6 +168,8 @@ RT_API_ATTRS void CopyElement(const Descriptor &to, const SubscriptValue toAt[],
         std::size_t nComponents{componentDesc.Elements()};
         for (std::size_t j{0}; j < nComponents; ++j, ++component) {
           if (component->genre() == typeInfo::Component::Genre::Allocatable ||
+              component->genre() ==
+                  typeInfo::Component::Genre::AllocatableDevice ||
               component->genre() == typeInfo::Component::Genre::Automatic) {
             Descriptor &toDesc{
                 *reinterpret_cast<Descriptor *>(toPtr + component->offset())};

flang-rt/lib/runtime/derived.cpp

@@ -63,7 +63,8 @@ RT_API_ATTRS int InitializeTicket::Continue(WorkQueue &workQueue) {
   char *rawInstance{instance_.OffsetElement<char>()};
   for (; !Componentwise::IsComplete(); SkipToNextComponent()) {
     char *rawComponent{rawInstance + component_->offset()};
-    if (component_->genre() == typeInfo::Component::Genre::Allocatable) {
+    if (component_->genre() == typeInfo::Component::Genre::Allocatable ||
+        component_->genre() == typeInfo::Component::Genre::AllocatableDevice) {
       Descriptor &allocDesc{*reinterpret_cast<Descriptor *>(rawComponent)};
       component_->EstablishDescriptor(
           allocDesc, instance_, workQueue.terminator());
@@ -72,7 +73,8 @@ RT_API_ATTRS int InitializeTicket::Continue(WorkQueue &workQueue) {
       // non-allocatable non-automatic components
       std::size_t bytes{component_->SizeInBytes(instance_)};
       runtime::memcpy(rawComponent, init, bytes);
-    } else if (component_->genre() == typeInfo::Component::Genre::Pointer) {
+    } else if (component_->genre() == typeInfo::Component::Genre::Pointer ||
+        component_->genre() == typeInfo::Component::Genre::PointerDevice) {
       // Data pointers without explicit initialization are established
       // so that they are valid right-hand side targets of pointer
       // assignment statements.
@@ -143,7 +145,8 @@ RT_API_ATTRS int InitializeClone(const Descriptor &clone,
 
 RT_API_ATTRS int InitializeCloneTicket::Continue(WorkQueue &workQueue) {
   while (!IsComplete()) {
-    if (component_->genre() == typeInfo::Component::Genre::Allocatable) {
+    if (component_->genre() == typeInfo::Component::Genre::Allocatable ||
+        component_->genre() == typeInfo::Component::Genre::AllocatableDevice) {
       Descriptor &origDesc{*instance_.ElementComponent<Descriptor>(
           subscripts_, component_->offset())};
       if (origDesc.IsAllocated()) {
@@ -320,7 +323,9 @@ RT_API_ATTRS int FinalizeTicket::Begin(WorkQueue &workQueue) {
 
 RT_API_ATTRS int FinalizeTicket::Continue(WorkQueue &workQueue) {
   while (!IsComplete()) {
-    if (component_->genre() == typeInfo::Component::Genre::Allocatable &&
+    if ((component_->genre() == typeInfo::Component::Genre::Allocatable ||
+            component_->genre() ==
+                typeInfo::Component::Genre::AllocatableDevice) &&
         component_->category() == TypeCategory::Derived) {
       // Component may be polymorphic or unlimited polymorphic. Need to use the
       // dynamic type to check whether finalization is needed.
@@ -342,6 +347,7 @@ RT_API_ATTRS int FinalizeTicket::Continue(WorkQueue &workQueue) {
         }
       }
     } else if (component_->genre() == typeInfo::Component::Genre::Allocatable ||
+        component_->genre() == typeInfo::Component::Genre::AllocatableDevice ||
         component_->genre() == typeInfo::Component::Genre::Automatic) {
       if (const typeInfo::DerivedType *compType{component_->derivedType()};
           compType && !compType->noFinalizationNeeded()) {
@@ -424,7 +430,8 @@ RT_API_ATTRS int DestroyTicket::Continue(WorkQueue &workQueue) {
   // Contrary to finalization, the order of deallocation does not matter.
   while (!IsComplete()) {
     const auto *componentDerived{component_->derivedType()};
-    if (component_->genre() == typeInfo::Component::Genre::Allocatable) {
+    if (component_->genre() == typeInfo::Component::Genre::Allocatable ||
+        component_->genre() == typeInfo::Component::Genre::AllocatableDevice) {
       if (fixedStride_ &&
           (!componentDerived || componentDerived->noDestructionNeeded())) {
         // common fast path, just deallocate in every element

flang-rt/lib/runtime/descriptor.cpp

@@ -33,7 +33,7 @@ RT_API_ATTRS Descriptor &Descriptor::operator=(const Descriptor &that) {
 
 RT_API_ATTRS void Descriptor::Establish(TypeCode t, std::size_t elementBytes,
     void *p, int rank, const SubscriptValue *extent,
-    ISO::CFI_attribute_t attribute, bool addendum) {
+    ISO::CFI_attribute_t attribute, bool addendum, int allocatorIdx) {
   Terminator terminator{__FILE__, __LINE__};
   int cfiStatus{ISO::VerifyEstablishParameters(&raw_, p, attribute, t.raw(),
       elementBytes, rank, extent, /*external=*/false)};
@@ -60,6 +60,7 @@ RT_API_ATTRS void Descriptor::Establish(TypeCode t, std::size_t elementBytes,
   if (a) {
     new (a) DescriptorAddendum{};
   }
+  SetAllocIdx(allocatorIdx);
 }
 
 RT_API_ATTRS std::size_t Descriptor::BytesFor(TypeCategory category, int kind) {
@@ -71,21 +72,22 @@ RT_API_ATTRS std::size_t Descriptor::BytesFor(TypeCategory category, int kind) {
 
 RT_API_ATTRS void Descriptor::Establish(TypeCategory c, int kind, void *p,
     int rank, const SubscriptValue *extent, ISO::CFI_attribute_t attribute,
-    bool addendum) {
+    bool addendum, int allocatorIdx) {
   Establish(TypeCode(c, kind), BytesFor(c, kind), p, rank, extent, attribute,
-      addendum);
+      addendum, allocatorIdx);
 }
 
 RT_API_ATTRS void Descriptor::Establish(int characterKind,
     std::size_t characters, void *p, int rank, const SubscriptValue *extent,
-    ISO::CFI_attribute_t attribute, bool addendum) {
+    ISO::CFI_attribute_t attribute, bool addendum, int allocatorIdx) {
   Establish(TypeCode{TypeCategory::Character, characterKind},
-      characterKind * characters, p, rank, extent, attribute, addendum);
+      characterKind * characters, p, rank, extent, attribute, addendum,
+      allocatorIdx);
 }
 
 RT_API_ATTRS void Descriptor::Establish(const typeInfo::DerivedType &dt,
     void *p, int rank, const SubscriptValue *extent,
-    ISO::CFI_attribute_t attribute) {
+    ISO::CFI_attribute_t attribute, int allocatorIdx) {
   auto elementBytes{static_cast<std::size_t>(dt.sizeInBytes())};
   ISO::EstablishDescriptor(
       &raw_, p, attribute, CFI_type_struct, elementBytes, rank, extent);
@@ -99,6 +101,7 @@ RT_API_ATTRS void Descriptor::Establish(const typeInfo::DerivedType &dt,
   }
   SetHasAddendum();
   new (Addendum()) DescriptorAddendum{&dt};
+  SetAllocIdx(allocatorIdx);
 }
 
 RT_API_ATTRS void Descriptor::UncheckedScalarEstablish(

flang-rt/lib/runtime/type-info.cpp

@@ -95,10 +95,16 @@ RT_API_ATTRS std::size_t Component::SizeInBytes(
 RT_API_ATTRS void Component::EstablishDescriptor(Descriptor &descriptor,
     const Descriptor &container, Terminator &terminator) const {
   ISO::CFI_attribute_t attribute{static_cast<ISO::CFI_attribute_t>(
-      genre_ == Genre::Allocatable   ? CFI_attribute_allocatable
-          : genre_ == Genre::Pointer ? CFI_attribute_pointer
-                                     : CFI_attribute_other)};
+      genre_ == Genre::Allocatable || genre_ == Genre::AllocatableDevice
+          ? CFI_attribute_allocatable
+          : genre_ == Genre::Pointer || genre_ == Genre::PointerDevice
+          ? CFI_attribute_pointer
+          : CFI_attribute_other)};
   TypeCategory cat{category()};
+  unsigned allocatorIdx{
+      genre_ == Genre::AllocatableDevice || genre_ == Genre::PointerDevice
+          ? kDeviceAllocatorPos
+          : kDefaultAllocator};
   if (cat == TypeCategory::Character) {
     std::size_t lengthInChars{0};
     if (auto length{characterLen_.GetValue(&container)}) {
@@ -107,19 +113,22 @@ RT_API_ATTRS void Component::EstablishDescriptor(Descriptor &descriptor,
       RUNTIME_CHECK(
           terminator, characterLen_.genre() == Value::Genre::Deferred);
     }
-    descriptor.Establish(
-        kind_, lengthInChars, nullptr, rank_, nullptr, attribute);
+    descriptor.Establish(kind_, lengthInChars, nullptr, rank_, nullptr,
+        attribute, false, allocatorIdx);
   } else if (cat == TypeCategory::Derived) {
     if (const DerivedType * type{derivedType()}) {
-      descriptor.Establish(*type, nullptr, rank_, nullptr, attribute);
+      descriptor.Establish(
+          *type, nullptr, rank_, nullptr, attribute, allocatorIdx);
     } else { // unlimited polymorphic
       descriptor.Establish(TypeCode{TypeCategory::Derived, 0}, 0, nullptr,
-          rank_, nullptr, attribute, true);
+          rank_, nullptr, attribute, true, allocatorIdx);
     }
   } else {
-    descriptor.Establish(cat, kind_, nullptr, rank_, nullptr, attribute);
+    descriptor.Establish(
+        cat, kind_, nullptr, rank_, nullptr, attribute, false, allocatorIdx);
   }
-  if (rank_ && genre_ != Genre::Allocatable && genre_ != Genre::Pointer) {
+  if (rank_ && genre_ != Genre::Allocatable && genre_ != Genre::Pointer &&
+      genre_ != Genre::AllocatableDevice && genre_ != Genre::PointerDevice) {
     const typeInfo::Value *boundValues{bounds()};
     RUNTIME_CHECK(terminator, boundValues != nullptr);
     auto byteStride{static_cast<SubscriptValue>(descriptor.ElementBytes())};
@@ -267,13 +276,17 @@ FILE *Component::Dump(FILE *f) const {
   std::fputs("    name: ", f);
   DumpScalarCharacter(f, name(), "Component::name");
   if (genre_ == Genre::Data) {
-    std::fputs("    Data       ", f);
+    std::fputs("    Data            ", f);
   } else if (genre_ == Genre::Pointer) {
-    std::fputs("    Pointer    ", f);
+    std::fputs("    Pointer          ", f);
+  } else if (genre_ == Genre::PointerDevice) {
+    std::fputs("    PointerDevice    ", f);
   } else if (genre_ == Genre::Allocatable) {
-    std::fputs("    Allocatable", f);
+    std::fputs("    Allocatable.     ", f);
+  } else if (genre_ == Genre::AllocatableDevice) {
+    std::fputs("    AllocatableDevice", f);
   } else if (genre_ == Genre::Automatic) {
-    std::fputs("    Automatic  ", f);
+    std::fputs("    Automatic        ", f);
   } else {
     std::fprintf(f, "    (bad genre 0x%x)", static_cast<int>(genre_));
   }

flang/include/flang/Semantics/tools.h

@@ -225,6 +225,14 @@ inline bool HasCUDAAttr(const Symbol &sym) {
 
 bool HasCUDAComponent(const Symbol &sym);
 
+inline bool IsCUDADevice(const Symbol &sym) {
+  if (const auto *details{sym.GetUltimate().detailsIf<ObjectEntityDetails>()}) {
+    return details->cudaDataAttr() &&
+        *details->cudaDataAttr() == common::CUDADataAttr::Device;
+  }
+  return false;
+}
+
 inline bool IsCUDAShared(const Symbol &sym) {
   if (const auto *details{sym.GetUltimate().detailsIf<ObjectEntityDetails>()}) {
     if (details->cudaDataAttr() &&

flang/lib/Semantics/runtime-type-info.cpp

@@ -771,6 +771,8 @@ evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent(
   auto &foldingContext{context_.foldingContext()};
   auto typeAndShape{evaluate::characteristics::TypeAndShape::Characterize(
       symbol, foldingContext)};
+  bool isDevice{object.cudaDataAttr() &&
+      *object.cudaDataAttr() == common::CUDADataAttr::Device};
   CHECK(typeAndShape.has_value());
   auto dyType{typeAndShape->type()};
   int rank{typeAndShape->Rank()};
@@ -883,9 +885,19 @@ evaluate::StructureConstructor RuntimeTableBuilder::DescribeComponent(
   // Default component initialization
   bool hasDataInit{false};
   if (IsAllocatable(symbol)) {
-    AddValue(values, componentSchema_, "genre"s, GetEnumValue("allocatable"));
+    if (isDevice) {
+      AddValue(values, componentSchema_, "genre"s,
+          GetEnumValue("allocatabledevice"));
+    } else {
+      AddValue(values, componentSchema_, "genre"s, GetEnumValue("allocatable"));
+    }
   } else if (IsPointer(symbol)) {
-    AddValue(values, componentSchema_, "genre"s, GetEnumValue("pointer"));
+    if (isDevice) {
+      AddValue(
+          values, componentSchema_, "genre"s, GetEnumValue("pointerdevice"));
+    } else {
+      AddValue(values, componentSchema_, "genre"s, GetEnumValue("pointer"));
+    }
     hasDataInit = InitializeDataPointer(
         values, symbol, object, scope, dtScope, distinctName);
   } else if (IsAutomatic(symbol)) {

flang/module/__fortran_type_info.f90

@@ -75,7 +75,7 @@
   end type
 
   enum, bind(c) ! Component::Genre
-    enumerator :: Data = 1, Pointer = 2, Allocatable = 3, Automatic = 4
+    enumerator :: Data = 1, Pointer = 2, Allocatable = 3, Automatic = 4, PointerDevice = 5, AllocatableDevice = 6
   end enum
 
   enum, bind(c) ! common::TypeCategory

flang/test/Lower/CUDA/cuda-allocatable-device.cuf

@@ -0,0 +1,14 @@
+! RUN: bbc -emit-hlfir -fcuda %s -o - | FileCheck %s
+
+module m
+  type device_array
+    real(kind=8), allocatable, dimension(:), device :: ad
+    real(kind=8), pointer, dimension(:), device :: pd
+  end type
+
+  type(device_array), allocatable :: da(:)
+end module
+
+! CHECK-LABEL: fir.global linkonce_odr @_QMmE.c.device_array
+! CHECK: fir.insert_value %{{.*}}, %c6{{.*}}, ["genre"
+! CHECK: fir.insert_value %{{.*}}, %c5{{.*}}, ["genre"