flang/runtime/derived.cpp

   1 //===-- runtime/derived.cpp -----------------------------------------------===//
   2 //
   3 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
   4 // See https://llvm.org/LICENSE.txt for license information.
   5 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
   6 //
   7 //===----------------------------------------------------------------------===//
   8
   9 #include "derived.h"
  10 #include "stat.h"
  11 #include "terminator.h"
  12 #include "tools.h"
  13 #include "type-info.h"
  14 #include "flang/Runtime/descriptor.h"
  15
  16 namespace Fortran::runtime {
  17
  18 RT_OFFLOAD_API_GROUP_BEGIN
  19
  20 // Fill "extents" array with the extents of component "comp" from derived type
  21 // instance "derivedInstance".
  22 static RT_API_ATTRS void GetComponentExtents(SubscriptValue (&extents)[maxRank],
  23     const typeInfo::Component &comp, const Descriptor &derivedInstance) {
  24   const typeInfo::Value *bounds{comp.bounds()};
  25   for (int dim{0}; dim < comp.rank(); ++dim) {
  26     auto lb{bounds[2 * dim].GetValue(&derivedInstance).value_or(0)};
  27     auto ub{bounds[2 * dim + 1].GetValue(&derivedInstance).value_or(0)};
  28     extents[dim] = ub >= lb ? static_cast<SubscriptValue>(ub - lb + 1) : 0;
  29   }
  30 }
  31
  32 RT_API_ATTRS int Initialize(const Descriptor &instance,
  33     const typeInfo::DerivedType &derived, Terminator &terminator, bool hasStat,
  34     const Descriptor *errMsg) {
  35   const Descriptor &componentDesc{derived.component()};
  36   std::size_t elements{instance.Elements()};
  37   int stat{StatOk};
  38   // Initialize data components in each element; the per-element iterations
  39   // constitute the inner loops, not the outer ones
  40   std::size_t myComponents{componentDesc.Elements()};
  41   for (std::size_t k{0}; k < myComponents; ++k) {
  42     const auto &comp{
  43         *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)};
  44     SubscriptValue at[maxRank];
  45     instance.GetLowerBounds(at);
  46     if (comp.genre() == typeInfo::Component::Genre::Allocatable ||
  47         comp.genre() == typeInfo::Component::Genre::Automatic) {
  48       for (std::size_t j{0}; j++ < elements; instance.IncrementSubscripts(at)) {
  49         Descriptor &allocDesc{
  50             *instance.ElementComponent<Descriptor>(at, comp.offset())};
  51         comp.EstablishDescriptor(allocDesc, instance, terminator);
  52         allocDesc.raw().attribute = CFI_attribute_allocatable;
  53         if (comp.genre() == typeInfo::Component::Genre::Automatic) {
  54           stat = ReturnError(terminator, allocDesc.Allocate(), errMsg, hasStat);
  55           if (stat == StatOk) {
  56             if (const DescriptorAddendum * addendum{allocDesc.Addendum()}) {
  57               if (const auto *derived{addendum->derivedType()}) {
  58                 if (!derived->noInitializationNeeded()) {
  59                   stat = Initialize(
  60                       allocDesc, *derived, terminator, hasStat, errMsg);
  61                 }
  62               }
  63             }
  64           }
  65           if (stat != StatOk) {
  66             break;
  67           }
  68         }
  69       }
  70     } else if (const void *init{comp.initialization()}) {
  71       // Explicit initialization of data pointers and
  72       // non-allocatable non-automatic components
  73       std::size_t bytes{comp.SizeInBytes(instance)};
  74       for (std::size_t j{0}; j++ < elements; instance.IncrementSubscripts(at)) {
  75         char *ptr{instance.ElementComponent<char>(at, comp.offset())};
  76         std::memcpy(ptr, init, bytes);
  77       }
  78     } else if (comp.genre() == typeInfo::Component::Genre::Pointer) {
  79       // Data pointers without explicit initialization are established
  80       // so that they are valid right-hand side targets of pointer
  81       // assignment statements.
  82       for (std::size_t j{0}; j++ < elements; instance.IncrementSubscripts(at)) {
  83         Descriptor &ptrDesc{
  84             *instance.ElementComponent<Descriptor>(at, comp.offset())};
  85         comp.EstablishDescriptor(ptrDesc, instance, terminator);
  86         ptrDesc.raw().attribute = CFI_attribute_pointer;
  87       }
  88     } else if (comp.genre() == typeInfo::Component::Genre::Data &&
  89         comp.derivedType() && !comp.derivedType()->noInitializationNeeded()) {
  90       // Default initialization of non-pointer non-allocatable/automatic
  91       // data component.  Handles parent component's elements.  Recursive.
  92       SubscriptValue extents[maxRank];
  93       GetComponentExtents(extents, comp, instance);
  94       StaticDescriptor<maxRank, true, 0> staticDescriptor;
  95       Descriptor &compDesc{staticDescriptor.descriptor()};
  96       const typeInfo::DerivedType &compType{*comp.derivedType()};
  97       for (std::size_t j{0}; j++ < elements; instance.IncrementSubscripts(at)) {
  98         compDesc.Establish(compType,
  99             instance.ElementComponent<char>(at, comp.offset()), comp.rank(),
 100             extents);
 101         stat = Initialize(compDesc, compType, terminator, hasStat, errMsg);
 102         if (stat != StatOk) {
 103           break;
 104         }
 105       }
 106     }
 107   }
 108   // Initialize procedure pointer components in each element
 109   const Descriptor &procPtrDesc{derived.procPtr()};
 110   std::size_t myProcPtrs{procPtrDesc.Elements()};
 111   for (std::size_t k{0}; k < myProcPtrs; ++k) {
 112     const auto &comp{
 113         *procPtrDesc.ZeroBasedIndexedElement<typeInfo::ProcPtrComponent>(k)};
 114     SubscriptValue at[maxRank];
 115     instance.GetLowerBounds(at);
 116     for (std::size_t j{0}; j++ < elements; instance.IncrementSubscripts(at)) {
 117       auto &pptr{*instance.ElementComponent<typeInfo::ProcedurePointer>(
 118           at, comp.offset)};
 119       pptr = comp.procInitialization;
 120     }
 121   }
 122   return stat;
 123 }
 124
 125 static RT_API_ATTRS const typeInfo::SpecialBinding *FindFinal(
 126     const typeInfo::DerivedType &derived, int rank) {
 127   if (const auto *ranked{derived.FindSpecialBinding(
 128           typeInfo::SpecialBinding::RankFinal(rank))}) {
 129     return ranked;
 130   } else if (const auto *assumed{derived.FindSpecialBinding(
 131                  typeInfo::SpecialBinding::Which::AssumedRankFinal)}) {
 132     return assumed;
 133   } else {
 134     return derived.FindSpecialBinding(
 135         typeInfo::SpecialBinding::Which::ElementalFinal);
 136   }
 137 }
 138
 139 static RT_API_ATTRS void CallFinalSubroutine(const Descriptor &descriptor,
 140     const typeInfo::DerivedType &derived, Terminator *terminator) {
 141   if (const auto *special{FindFinal(derived, descriptor.rank())}) {
 142     if (special->which() == typeInfo::SpecialBinding::Which::ElementalFinal) {
 143       std::size_t elements{descriptor.Elements()};
 144       SubscriptValue at[maxRank];
 145       descriptor.GetLowerBounds(at);
 146       if (special->IsArgDescriptor(0)) {
 147         StaticDescriptor<maxRank, true, 8 /*?*/> statDesc;
 148         Descriptor &elemDesc{statDesc.descriptor()};
 149         elemDesc = descriptor;
 150         elemDesc.raw().attribute = CFI_attribute_pointer;
 151         elemDesc.raw().rank = 0;
 152         auto *p{special->GetProc<void (*)(const Descriptor &)>()};
 153         for (std::size_t j{0}; j++ < elements;
 154              descriptor.IncrementSubscripts(at)) {
 155           elemDesc.set_base_addr(descriptor.Element<char>(at));
 156           p(elemDesc);
 157         }
 158       } else {
 159         auto *p{special->GetProc<void (*)(char *)>()};
 160         for (std::size_t j{0}; j++ < elements;
 161              descriptor.IncrementSubscripts(at)) {
 162           p(descriptor.Element<char>(at));
 163         }
 164       }
 165     } else {
 166       StaticDescriptor<maxRank, true, 10> statDesc;
 167       Descriptor &copy{statDesc.descriptor()};
 168       const Descriptor *argDescriptor{&descriptor};
 169       if (descriptor.rank() > 0 && special->IsArgContiguous(0) &&
 170           !descriptor.IsContiguous()) {
 171         // The FINAL subroutine demands a contiguous array argument, but
 172         // this INTENT(OUT) or intrinsic assignment LHS isn't contiguous.
 173         // Finalize a shallow copy of the data.
 174         copy = descriptor;
 175         copy.set_base_addr(nullptr);
 176         copy.raw().attribute = CFI_attribute_allocatable;
 177         Terminator stubTerminator{"CallFinalProcedure() in Fortran runtime", 0};
 178         RUNTIME_CHECK(terminator ? *terminator : stubTerminator,
 179             copy.Allocate() == CFI_SUCCESS);
 180         ShallowCopyDiscontiguousToContiguous(copy, descriptor);
 181         argDescriptor = &copy;
 182       }
 183       if (special->IsArgDescriptor(0)) {
 184         StaticDescriptor<maxRank, true, 8 /*?*/> statDesc;
 185         Descriptor &tmpDesc{statDesc.descriptor()};
 186         tmpDesc = *argDescriptor;
 187         tmpDesc.raw().attribute = CFI_attribute_pointer;
 188         tmpDesc.Addendum()->set_derivedType(&derived);
 189         auto *p{special->GetProc<void (*)(const Descriptor &)>()};
 190         p(tmpDesc);
 191       } else {
 192         auto *p{special->GetProc<void (*)(char *)>()};
 193         p(argDescriptor->OffsetElement<char>());
 194       }
 195       if (argDescriptor == &copy) {
 196         ShallowCopyContiguousToDiscontiguous(descriptor, copy);
 197         copy.Deallocate();
 198       }
 199     }
 200   }
 201 }
 202
 203 // Fortran 2018 subclause 7.5.6.2
 204 RT_API_ATTRS void Finalize(const Descriptor &descriptor,
 205     const typeInfo::DerivedType &derived, Terminator *terminator) {
 206   if (derived.noFinalizationNeeded() || !descriptor.IsAllocated()) {
 207     return;
 208   }
 209   CallFinalSubroutine(descriptor, derived, terminator);
 210   const auto *parentType{derived.GetParentType()};
 211   bool recurse{parentType && !parentType->noFinalizationNeeded()};
 212   // If there's a finalizable parent component, handle it last, as required
 213   // by the Fortran standard (7.5.6.2), and do so recursively with the same
 214   // descriptor so that the rank is preserved.
 215   const Descriptor &componentDesc{derived.component()};
 216   std::size_t myComponents{componentDesc.Elements()};
 217   std::size_t elements{descriptor.Elements()};
 218   for (auto k{recurse ? std::size_t{1}
 219                       /* skip first component, it's the parent */
 220                       : 0};
 221        k < myComponents; ++k) {
 222     const auto &comp{
 223         *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)};
 224     SubscriptValue at[maxRank];
 225     descriptor.GetLowerBounds(at);
 226     if (comp.genre() == typeInfo::Component::Genre::Allocatable &&
 227         comp.category() == TypeCategory::Derived) {
 228       // Component may be polymorphic or unlimited polymorphic. Need to use the
 229       // dynamic type to check whether finalization is needed.
 230       for (std::size_t j{0}; j++ < elements;
 231            descriptor.IncrementSubscripts(at)) {
 232         const Descriptor &compDesc{
 233             *descriptor.ElementComponent<Descriptor>(at, comp.offset())};
 234         if (compDesc.IsAllocated()) {
 235           if (const DescriptorAddendum * addendum{compDesc.Addendum()}) {
 236             if (const typeInfo::DerivedType *
 237                 compDynamicType{addendum->derivedType()}) {
 238               if (!compDynamicType->noFinalizationNeeded()) {
 239                 Finalize(compDesc, *compDynamicType, terminator);
 240               }
 241             }
 242           }
 243         }
 244       }
 245     } else if (comp.genre() == typeInfo::Component::Genre::Allocatable ||
 246         comp.genre() == typeInfo::Component::Genre::Automatic) {
 247       if (const typeInfo::DerivedType * compType{comp.derivedType()}) {
 248         if (!compType->noFinalizationNeeded()) {
 249           for (std::size_t j{0}; j++ < elements;
 250                descriptor.IncrementSubscripts(at)) {
 251             const Descriptor &compDesc{
 252                 *descriptor.ElementComponent<Descriptor>(at, comp.offset())};
 253             if (compDesc.IsAllocated()) {
 254               Finalize(compDesc, *compType, terminator);
 255             }
 256           }
 257         }
 258       }
 259     } else if (comp.genre() == typeInfo::Component::Genre::Data &&
 260         comp.derivedType() && !comp.derivedType()->noFinalizationNeeded()) {
 261       SubscriptValue extents[maxRank];
 262       GetComponentExtents(extents, comp, descriptor);
 263       StaticDescriptor<maxRank, true, 0> staticDescriptor;
 264       Descriptor &compDesc{staticDescriptor.descriptor()};
 265       const typeInfo::DerivedType &compType{*comp.derivedType()};
 266       for (std::size_t j{0}; j++ < elements;
 267            descriptor.IncrementSubscripts(at)) {
 268         compDesc.Establish(compType,
 269             descriptor.ElementComponent<char>(at, comp.offset()), comp.rank(),
 270             extents);
 271         Finalize(compDesc, compType, terminator);
 272       }
 273     }
 274   }
 275   if (recurse) {
 276     StaticDescriptor<maxRank, true, 8 /*?*/> statDesc;
 277     Descriptor &tmpDesc{statDesc.descriptor()};
 278     tmpDesc = descriptor;
 279     tmpDesc.raw().attribute = CFI_attribute_pointer;
 280     tmpDesc.Addendum()->set_derivedType(parentType);
 281     tmpDesc.raw().elem_len = parentType->sizeInBytes();
 282     Finalize(tmpDesc, *parentType, terminator);
 283   }
 284 }
 285
 286 // The order of finalization follows Fortran 2018 7.5.6.2, with
 287 // elementwise finalization of non-parent components taking place
 288 // before parent component finalization, and with all finalization
 289 // preceding any deallocation.
 290 RT_API_ATTRS void Destroy(const Descriptor &descriptor, bool finalize,
 291     const typeInfo::DerivedType &derived, Terminator *terminator) {
 292   if (derived.noDestructionNeeded() || !descriptor.IsAllocated()) {
 293     return;
 294   }
 295   if (finalize && !derived.noFinalizationNeeded()) {
 296     Finalize(descriptor, derived, terminator);
 297   }
 298   // Deallocate all direct and indirect allocatable and automatic components.
 299   // Contrary to finalization, the order of deallocation does not matter.
 300   const Descriptor &componentDesc{derived.component()};
 301   std::size_t myComponents{componentDesc.Elements()};
 302   std::size_t elements{descriptor.Elements()};
 303   SubscriptValue at[maxRank];
 304   descriptor.GetLowerBounds(at);
 305   for (std::size_t k{0}; k < myComponents; ++k) {
 306     const auto &comp{
 307         *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)};
 308     const bool destroyComp{
 309         comp.derivedType() && !comp.derivedType()->noDestructionNeeded()};
 310     if (comp.genre() == typeInfo::Component::Genre::Allocatable ||
 311         comp.genre() == typeInfo::Component::Genre::Automatic) {
 312       for (std::size_t j{0}; j < elements; ++j) {
 313         Descriptor *d{
 314             descriptor.ElementComponent<Descriptor>(at, comp.offset())};
 315         if (destroyComp) {
 316           Destroy(*d, /*finalize=*/false, *comp.derivedType(), terminator);
 317         }
 318         d->Deallocate();
 319         descriptor.IncrementSubscripts(at);
 320       }
 321     } else if (destroyComp &&
 322         comp.genre() == typeInfo::Component::Genre::Data) {
 323       SubscriptValue extents[maxRank];
 324       GetComponentExtents(extents, comp, descriptor);
 325       StaticDescriptor<maxRank, true, 0> staticDescriptor;
 326       Descriptor &compDesc{staticDescriptor.descriptor()};
 327       const typeInfo::DerivedType &compType{*comp.derivedType()};
 328       for (std::size_t j{0}; j++ < elements;
 329            descriptor.IncrementSubscripts(at)) {
 330         compDesc.Establish(compType,
 331             descriptor.ElementComponent<char>(at, comp.offset()), comp.rank(),
 332             extents);
 333         Destroy(compDesc, /*finalize=*/false, *comp.derivedType(), terminator);
 334       }
 335     }
 336   }
 337 }
 338
 339 RT_API_ATTRS bool HasDynamicComponent(const Descriptor &descriptor) {
 340   if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {
 341     if (const auto *derived = addendum->derivedType()) {
 342       // Destruction is needed if and only if there are direct or indirect
 343       // allocatable or automatic components.
 344       return !derived->noDestructionNeeded();
 345     }
 346   }
 347   return false;
 348 }
 349
 350 RT_OFFLOAD_API_GROUP_END
 351 } // namespace Fortran::runtime