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.OffsetElement<char>(j * byteStride + 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         extent[dim] = bounds[2 * dim].GetValue(&descriptor).value_or(0) -
192             bounds[2 * dim + 1].GetValue(&descriptor).value_or(0) + 1;
193       }
194       StaticDescriptor<maxRank, true, 0> staticDescriptor;
195       Descriptor &compDesc{staticDescriptor.descriptor()};
196       const typeInfo::DerivedType &compType{*comp.derivedType()};
197       for (std::size_t j{0}; j < elements; ++j) {
198         compDesc.Establish(compType,
199             descriptor.OffsetElement<char>(j * byteStride + comp.offset()),
200             comp.rank(), extent);
201         Finalize(compDesc, compType);
202       }
203     }
204   }
205   if (recurse) {
206     Finalize(descriptor, *parentType);
207   }
208 }
209 
210 // The order of finalization follows Fortran 2018 7.5.6.2, with
211 // elementwise finalization of non-parent components taking place
212 // before parent component finalization, and with all finalization
213 // preceding any deallocation.
214 void Destroy(const Descriptor &descriptor, bool finalize,
215     const typeInfo::DerivedType &derived) {
216   if (derived.noDestructionNeeded() || !descriptor.IsAllocated()) {
217     return;
218   }
219   if (finalize && !derived.noFinalizationNeeded()) {
220     Finalize(descriptor, derived);
221   }
222   const Descriptor &componentDesc{derived.component()};
223   std::size_t myComponents{componentDesc.Elements()};
224   std::size_t elements{descriptor.Elements()};
225   std::size_t byteStride{descriptor.ElementBytes()};
226   for (std::size_t k{0}; k < myComponents; ++k) {
227     const auto &comp{
228         *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)};
229     if (comp.genre() == typeInfo::Component::Genre::Allocatable ||
230         comp.genre() == typeInfo::Component::Genre::Automatic) {
231       for (std::size_t j{0}; j < elements; ++j) {
232         descriptor.OffsetElement<Descriptor>(j * byteStride + comp.offset())
233             ->Deallocate();
234       }
235     }
236   }
237 }
238 
239 } // namespace Fortran::runtime
240