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