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