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

source code of flang/runtime/derived.cpp