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 "type-info.h"
  13 #include "flang/Runtime/descriptor.h"
  14
  15 namespace Fortran::runtime {
  16
  17 int Initialize(const Descriptor &instance, const typeInfo::DerivedType &derived,
  18     Terminator &terminator, bool hasStat, const Descriptor *errMsg) {
  19   const Descriptor &componentDesc{derived.component()};
  20   std::size_t elements{instance.Elements()};
  21   std::size_t byteStride{instance.ElementBytes()};
  22   int stat{StatOk};
  23   // Initialize data components in each element; the per-element iteration
  24   // constitutes the inner loops, not outer
  25   std::size_t myComponents{componentDesc.Elements()};
  26   for (std::size_t k{0}; k < myComponents; ++k) {
  27     const auto &comp{
  28         *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)};
  29     if (comp.genre() == typeInfo::Component::Genre::Allocatable ||
  30         comp.genre() == typeInfo::Component::Genre::Automatic) {
  31       for (std::size_t j{0}; j < elements; ++j) {
  32         Descriptor &allocDesc{*instance.OffsetElement<Descriptor>(
  33             j * byteStride + comp.offset())};
  34         comp.EstablishDescriptor(allocDesc, instance, terminator);
  35         allocDesc.raw().attribute = CFI_attribute_allocatable;
  36         if (comp.genre() == typeInfo::Component::Genre::Automatic) {
  37           stat = ReturnError(terminator, allocDesc.Allocate(), errMsg, hasStat);
  38           if (stat == StatOk) {
  39             stat = Initialize(allocDesc, derived, terminator, hasStat, errMsg);
  40           }
  41           if (stat != StatOk) {
  42             break;
  43           }
  44         }
  45       }
  46     } else if (const void *init{comp.initialization()}) {
  47       // Explicit initialization of data pointers and
  48       // non-allocatable non-automatic components
  49       std::size_t bytes{comp.SizeInBytes(instance)};
  50       for (std::size_t j{0}; j < elements; ++j) {
  51         char *ptr{instance.ZeroBasedIndexedElement<char>(j) + comp.offset()};
  52         std::memcpy(ptr, init, bytes);
  53       }
  54     } else if (comp.genre() == typeInfo::Component::Genre::Data &&
  55         comp.derivedType() && !comp.derivedType()->noInitializationNeeded()) {
  56       // Default initialization of non-pointer non-allocatable/automatic
  57       // data component.  Handles parent component's elements.  Recursive.
  58       SubscriptValue extent[maxRank];
  59       const typeInfo::Value *bounds{comp.bounds()};
  60       for (int dim{0}; dim < comp.rank(); ++dim) {
  61         typeInfo::TypeParameterValue lb{
  62             bounds[2 * dim].GetValue(&instance).value_or(0)};
  63         typeInfo::TypeParameterValue ub{
  64             bounds[2 * dim + 1].GetValue(&instance).value_or(0)};
  65         extent[dim] = ub >= lb ? ub - lb + 1 : 0;
  66       }
  67       StaticDescriptor<maxRank, true, 0> staticDescriptor;
  68       Descriptor &compDesc{staticDescriptor.descriptor()};
  69       const typeInfo::DerivedType &compType{*comp.derivedType()};
  70       for (std::size_t j{0}; j < elements; ++j) {
  71         compDesc.Establish(compType,
  72             instance.OffsetElement<char>(j * byteStride + comp.offset()),
  73             comp.rank(), extent);
  74         stat = Initialize(compDesc, compType, terminator, hasStat, errMsg);
  75         if (stat != StatOk) {
  76           break;
  77         }
  78       }
  79     }
  80   }
  81   // Initialize procedure pointer components in each element
  82   const Descriptor &procPtrDesc{derived.procPtr()};
  83   std::size_t myProcPtrs{procPtrDesc.Elements()};
  84   for (std::size_t k{0}; k < myProcPtrs; ++k) {
  85     const auto &comp{
  86         *procPtrDesc.ZeroBasedIndexedElement<typeInfo::ProcPtrComponent>(k)};
  87     for (std::size_t j{0}; j < elements; ++j) {
  88       auto &pptr{*instance.OffsetElement<typeInfo::ProcedurePointer>(
  89           j * byteStride + comp.offset)};
  90       pptr = comp.procInitialization;
  91     }
  92   }
  93   return stat;
  94 }
  95
  96 static const typeInfo::SpecialBinding *FindFinal(
  97     const typeInfo::DerivedType &derived, int rank) {
  98   if (const auto *ranked{derived.FindSpecialBinding(
  99           typeInfo::SpecialBinding::RankFinal(rank))}) {
 100     return ranked;
 101   } else if (const auto *assumed{derived.FindSpecialBinding(
 102                  typeInfo::SpecialBinding::Which::AssumedRankFinal)}) {
 103     return assumed;
 104   } else {
 105     return derived.FindSpecialBinding(
 106         typeInfo::SpecialBinding::Which::ElementalFinal);
 107   }
 108 }
 109
 110 static void CallFinalSubroutine(
 111     const Descriptor &descriptor, const typeInfo::DerivedType &derived) {
 112   if (const auto *special{FindFinal(derived, descriptor.rank())}) {
 113     // The following code relies on the fact that finalizable objects
 114     // must be contiguous.
 115     if (special->which() == typeInfo::SpecialBinding::Which::ElementalFinal) {
 116       std::size_t byteStride{descriptor.ElementBytes()};
 117       std::size_t elements{descriptor.Elements()};
 118       if (special->IsArgDescriptor(0)) {
 119         StaticDescriptor<maxRank, true, 8 /*?*/> statDesc;
 120         Descriptor &elemDesc{statDesc.descriptor()};
 121         elemDesc = descriptor;
 122         elemDesc.raw().attribute = CFI_attribute_pointer;
 123         elemDesc.raw().rank = 0;
 124         auto *p{special->GetProc<void (*)(const Descriptor &)>()};
 125         for (std::size_t j{0}; j < elements; ++j) {
 126           elemDesc.set_base_addr(
 127               descriptor.OffsetElement<char>(j * byteStride));
 128           p(elemDesc);
 129         }
 130       } else {
 131         auto *p{special->GetProc<void (*)(char *)>()};
 132         for (std::size_t j{0}; j < elements; ++j) {
 133           p(descriptor.OffsetElement<char>(j * byteStride));
 134         }
 135       }
 136     } else if (special->IsArgDescriptor(0)) {
 137       StaticDescriptor<maxRank, true, 8 /*?*/> statDesc;
 138       Descriptor &tmpDesc{statDesc.descriptor()};
 139       tmpDesc = descriptor;
 140       tmpDesc.raw().attribute = CFI_attribute_pointer;
 141       tmpDesc.Addendum()->set_derivedType(&derived);
 142       auto *p{special->GetProc<void (*)(const Descriptor &)>()};
 143       p(tmpDesc);
 144     } else {
 145       auto *p{special->GetProc<void (*)(char *)>()};
 146       p(descriptor.OffsetElement<char>());
 147     }
 148   }
 149 }
 150
 151 // Fortran 2018 subclause 7.5.6.2
 152 void Finalize(
 153     const Descriptor &descriptor, const typeInfo::DerivedType &derived) {
 154   if (derived.noFinalizationNeeded() || !descriptor.IsAllocated()) {
 155     return;
 156   }
 157   CallFinalSubroutine(descriptor, derived);
 158   const auto *parentType{derived.GetParentType()};
 159   bool recurse{parentType && !parentType->noFinalizationNeeded()};
 160   // If there's a finalizable parent component, handle it last, as required
 161   // by the Fortran standard (7.5.6.2), and do so recursively with the same
 162   // descriptor so that the rank is preserved.
 163   const Descriptor &componentDesc{derived.component()};
 164   std::size_t myComponents{componentDesc.Elements()};
 165   std::size_t elements{descriptor.Elements()};
 166   std::size_t byteStride{descriptor.ElementBytes()};
 167   for (auto k{recurse
 168                ? std::size_t{1} /* skip first component, it's the parent */
 169                : 0};
 170        k < myComponents; ++k) {
 171     const auto &comp{
 172         *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)};
 173     if (comp.genre() == typeInfo::Component::Genre::Allocatable ||
 174         comp.genre() == typeInfo::Component::Genre::Automatic) {
 175       if (const typeInfo::DerivedType * compType{comp.derivedType()}) {
 176         if (!compType->noFinalizationNeeded()) {
 177           for (std::size_t j{0}; j < elements; ++j) {
 178             const Descriptor &compDesc{*descriptor.OffsetElement<Descriptor>(
 179                 j * byteStride + comp.offset())};
 180             if (compDesc.IsAllocated()) {
 181               Finalize(compDesc, *compType);
 182             }
 183           }
 184         }
 185       }
 186     } else if (comp.genre() == typeInfo::Component::Genre::Data &&
 187         comp.derivedType() && !comp.derivedType()->noFinalizationNeeded()) {
 188       SubscriptValue extent[maxRank];
 189       const typeInfo::Value *bounds{comp.bounds()};
 190       for (int dim{0}; dim < comp.rank(); ++dim) {
 191         SubscriptValue lb{bounds[2 * dim].GetValue(&descriptor).value_or(0)};
 192         SubscriptValue ub{
 193             bounds[2 * dim + 1].GetValue(&descriptor).value_or(0)};
 194         extent[dim] = ub >= lb ? ub - lb + 1 : 0;
 195       }
 196       StaticDescriptor<maxRank, true, 0> staticDescriptor;
 197       Descriptor &compDesc{staticDescriptor.descriptor()};
 198       const typeInfo::DerivedType &compType{*comp.derivedType()};
 199       for (std::size_t j{0}; j < elements; ++j) {
 200         compDesc.Establish(compType,
 201             descriptor.OffsetElement<char>(j * byteStride + comp.offset()),
 202             comp.rank(), extent);
 203         Finalize(compDesc, compType);
 204       }
 205     }
 206   }
 207   if (recurse) {
 208     Finalize(descriptor, *parentType);
 209   }
 210 }
 211
 212 // The order of finalization follows Fortran 2018 7.5.6.2, with
 213 // elementwise finalization of non-parent components taking place
 214 // before parent component finalization, and with all finalization
 215 // preceding any deallocation.
 216 void Destroy(const Descriptor &descriptor, bool finalize,
 217     const typeInfo::DerivedType &derived) {
 218   if (derived.noDestructionNeeded() || !descriptor.IsAllocated()) {
 219     return;
 220   }
 221   if (finalize && !derived.noFinalizationNeeded()) {
 222     Finalize(descriptor, derived);
 223   }
 224   const Descriptor &componentDesc{derived.component()};
 225   std::size_t myComponents{componentDesc.Elements()};
 226   std::size_t elements{descriptor.Elements()};
 227   std::size_t byteStride{descriptor.ElementBytes()};
 228   SubscriptValue at[maxRank];
 229   descriptor.GetLowerBounds(at);
 230   for (std::size_t k{0}; k < myComponents; ++k) {
 231     const auto &comp{
 232         *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)};
 233     if (comp.genre() == typeInfo::Component::Genre::Allocatable ||
 234         comp.genre() == typeInfo::Component::Genre::Automatic) {
 235       for (std::size_t j{0}; j < elements; ++j) {
 236         Descriptor *d{reinterpret_cast<Descriptor *>(
 237             descriptor.Element<char>(at) + comp.offset())};
 238         d->Deallocate();
 239         descriptor.IncrementSubscripts(at);
 240       }
 241     }
 242   }
 243 }
 244
 245 } // namespace Fortran::runtime