1//===-- lib/runtime/derived.cpp ---------------------------------*- C++ -*-===//
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 "flang-rt/runtime/derived.h"
10#include "flang-rt/runtime/descriptor.h"
11#include "flang-rt/runtime/stat.h"
12#include "flang-rt/runtime/terminator.h"
13#include "flang-rt/runtime/tools.h"
14#include "flang-rt/runtime/type-info.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 auto lb{bounds[2 * dim].GetValue(&derivedInstance).value_or(0)};
27 auto ub{bounds[2 * dim + 1].GetValue(&derivedInstance).value_or(0)};
28 extents[dim] = ub >= lb ? static_cast<SubscriptValue>(ub - lb + 1) : 0;
29 }
30}
31
32RT_API_ATTRS int Initialize(const Descriptor &instance,
33 const typeInfo::DerivedType &derived, Terminator &terminator, bool hasStat,
34 const Descriptor *errMsg) {
35 const Descriptor &componentDesc{derived.component()};
36 std::size_t elements{instance.Elements()};
37 int stat{StatOk};
38 // Initialize data components in each element; the per-element iterations
39 // constitute the inner loops, not the outer ones
40 std::size_t myComponents{componentDesc.Elements()};
41 for (std::size_t k{0}; k < myComponents; ++k) {
42 const auto &comp{
43 *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)};
44 SubscriptValue at[maxRank];
45 instance.GetLowerBounds(at);
46 if (comp.genre() == typeInfo::Component::Genre::Allocatable ||
47 comp.genre() == typeInfo::Component::Genre::Automatic) {
48 for (std::size_t j{0}; j++ < elements; instance.IncrementSubscripts(at)) {
49 Descriptor &allocDesc{
50 *instance.ElementComponent<Descriptor>(at, comp.offset())};
51 comp.EstablishDescriptor(allocDesc, instance, terminator);
52 allocDesc.raw().attribute = CFI_attribute_allocatable;
53 if (comp.genre() == typeInfo::Component::Genre::Automatic) {
54 stat = ReturnError(
55 terminator, allocDesc.Allocate(kNoAsyncObject), 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(ptr, init, 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
126RT_API_ATTRS int InitializeClone(const Descriptor &clone,
127 const Descriptor &orig, const typeInfo::DerivedType &derived,
128 Terminator &terminator, bool hasStat, const Descriptor *errMsg) {
129 const Descriptor &componentDesc{derived.component()};
130 std::size_t elements{orig.Elements()};
131 int stat{StatOk};
132
133 // Skip pointers and unallocated variables.
134 if (orig.IsPointer() || !orig.IsAllocated()) {
135 return stat;
136 }
137 // Initialize each data component.
138 std::size_t components{componentDesc.Elements()};
139 for (std::size_t i{0}; i < components; ++i) {
140 const typeInfo::Component &comp{
141 *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(i)};
142 SubscriptValue at[maxRank];
143 orig.GetLowerBounds(at);
144 // Allocate allocatable components that are also allocated in the original
145 // object.
146 if (comp.genre() == typeInfo::Component::Genre::Allocatable) {
147 // Initialize each element.
148 for (std::size_t j{0}; j < elements; ++j, orig.IncrementSubscripts(at)) {
149 Descriptor &origDesc{
150 *orig.ElementComponent<Descriptor>(at, comp.offset())};
151 Descriptor &cloneDesc{
152 *clone.ElementComponent<Descriptor>(at, comp.offset())};
153 if (origDesc.IsAllocated()) {
154 cloneDesc.ApplyMold(origDesc, origDesc.rank());
155 stat = ReturnError(
156 terminator, cloneDesc.Allocate(kNoAsyncObject), errMsg, hasStat);
157 if (stat == StatOk) {
158 if (const DescriptorAddendum * addendum{cloneDesc.Addendum()}) {
159 if (const typeInfo::DerivedType *
160 derived{addendum->derivedType()}) {
161 if (!derived->noInitializationNeeded()) {
162 // Perform default initialization for the allocated element.
163 stat = Initialize(
164 cloneDesc, *derived, terminator, hasStat, errMsg);
165 }
166 // Initialize derived type's allocatables.
167 if (stat == StatOk) {
168 stat = InitializeClone(cloneDesc, origDesc, *derived,
169 terminator, hasStat, errMsg);
170 }
171 }
172 }
173 }
174 }
175 if (stat != StatOk) {
176 break;
177 }
178 }
179 } else if (comp.genre() == typeInfo::Component::Genre::Data &&
180 comp.derivedType()) {
181 // Handle nested derived types.
182 const typeInfo::DerivedType &compType{*comp.derivedType()};
183 SubscriptValue extents[maxRank];
184 GetComponentExtents(extents, comp, orig);
185 // Data components don't have descriptors, allocate them.
186 StaticDescriptor<maxRank, true, 0> origStaticDesc;
187 StaticDescriptor<maxRank, true, 0> cloneStaticDesc;
188 Descriptor &origDesc{origStaticDesc.descriptor()};
189 Descriptor &cloneDesc{cloneStaticDesc.descriptor()};
190 // Initialize each element.
191 for (std::size_t j{0}; j < elements; ++j, orig.IncrementSubscripts(at)) {
192 origDesc.Establish(compType,
193 orig.ElementComponent<char>(at, comp.offset()), comp.rank(),
194 extents);
195 cloneDesc.Establish(compType,
196 clone.ElementComponent<char>(at, comp.offset()), comp.rank(),
197 extents);
198 stat = InitializeClone(
199 cloneDesc, origDesc, compType, terminator, hasStat, errMsg);
200 if (stat != StatOk) {
201 break;
202 }
203 }
204 }
205 }
206 return stat;
207}
208
209static RT_API_ATTRS const typeInfo::SpecialBinding *FindFinal(
210 const typeInfo::DerivedType &derived, int rank) {
211 if (const auto *ranked{derived.FindSpecialBinding(
212 typeInfo::SpecialBinding::RankFinal(rank))}) {
213 return ranked;
214 } else if (const auto *assumed{derived.FindSpecialBinding(
215 typeInfo::SpecialBinding::Which::AssumedRankFinal)}) {
216 return assumed;
217 } else {
218 return derived.FindSpecialBinding(
219 typeInfo::SpecialBinding::Which::ElementalFinal);
220 }
221}
222
223static RT_API_ATTRS void CallFinalSubroutine(const Descriptor &descriptor,
224 const typeInfo::DerivedType &derived, Terminator *terminator) {
225 if (const auto *special{FindFinal(derived, descriptor.rank())}) {
226 if (special->which() == typeInfo::SpecialBinding::Which::ElementalFinal) {
227 std::size_t elements{descriptor.Elements()};
228 SubscriptValue at[maxRank];
229 descriptor.GetLowerBounds(at);
230 if (special->IsArgDescriptor(0)) {
231 StaticDescriptor<maxRank, true, 8 /*?*/> statDesc;
232 Descriptor &elemDesc{statDesc.descriptor()};
233 elemDesc = descriptor;
234 elemDesc.raw().attribute = CFI_attribute_pointer;
235 elemDesc.raw().rank = 0;
236 auto *p{special->GetProc<void (*)(const Descriptor &)>()};
237 for (std::size_t j{0}; j++ < elements;
238 descriptor.IncrementSubscripts(at)) {
239 elemDesc.set_base_addr(descriptor.Element<char>(at));
240 p(elemDesc);
241 }
242 } else {
243 auto *p{special->GetProc<void (*)(char *)>()};
244 for (std::size_t j{0}; j++ < elements;
245 descriptor.IncrementSubscripts(at)) {
246 p(descriptor.Element<char>(at));
247 }
248 }
249 } else {
250 StaticDescriptor<maxRank, true, 10> statDesc;
251 Descriptor &copy{statDesc.descriptor()};
252 const Descriptor *argDescriptor{&descriptor};
253 if (descriptor.rank() > 0 && special->IsArgContiguous(0) &&
254 !descriptor.IsContiguous()) {
255 // The FINAL subroutine demands a contiguous array argument, but
256 // this INTENT(OUT) or intrinsic assignment LHS isn't contiguous.
257 // Finalize a shallow copy of the data.
258 copy = descriptor;
259 copy.set_base_addr(nullptr);
260 copy.raw().attribute = CFI_attribute_allocatable;
261 Terminator stubTerminator{"CallFinalProcedure() in Fortran runtime", 0};
262 RUNTIME_CHECK(terminator ? *terminator : stubTerminator,
263 copy.Allocate(kNoAsyncObject) == CFI_SUCCESS);
264 ShallowCopyDiscontiguousToContiguous(copy, descriptor);
265 argDescriptor = &copy;
266 }
267 if (special->IsArgDescriptor(0)) {
268 StaticDescriptor<maxRank, true, 8 /*?*/> statDesc;
269 Descriptor &tmpDesc{statDesc.descriptor()};
270 tmpDesc = *argDescriptor;
271 tmpDesc.raw().attribute = CFI_attribute_pointer;
272 tmpDesc.Addendum()->set_derivedType(&derived);
273 auto *p{special->GetProc<void (*)(const Descriptor &)>()};
274 p(tmpDesc);
275 } else {
276 auto *p{special->GetProc<void (*)(char *)>()};
277 p(argDescriptor->OffsetElement<char>());
278 }
279 if (argDescriptor == &copy) {
280 ShallowCopyContiguousToDiscontiguous(descriptor, copy);
281 copy.Deallocate();
282 }
283 }
284 }
285}
286
287// Fortran 2018 subclause 7.5.6.2
288RT_API_ATTRS void Finalize(const Descriptor &descriptor,
289 const typeInfo::DerivedType &derived, Terminator *terminator) {
290 if (derived.noFinalizationNeeded() || !descriptor.IsAllocated()) {
291 return;
292 }
293 CallFinalSubroutine(descriptor, derived, terminator);
294 const auto *parentType{derived.GetParentType()};
295 bool recurse{parentType && !parentType->noFinalizationNeeded()};
296 // If there's a finalizable parent component, handle it last, as required
297 // by the Fortran standard (7.5.6.2), and do so recursively with the same
298 // descriptor so that the rank is preserved.
299 const Descriptor &componentDesc{derived.component()};
300 std::size_t myComponents{componentDesc.Elements()};
301 std::size_t elements{descriptor.Elements()};
302 for (auto k{recurse ? std::size_t{1}
303 /* skip first component, it's the parent */
304 : 0};
305 k < myComponents; ++k) {
306 const auto &comp{
307 *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)};
308 SubscriptValue at[maxRank];
309 descriptor.GetLowerBounds(at);
310 if (comp.genre() == typeInfo::Component::Genre::Allocatable &&
311 comp.category() == TypeCategory::Derived) {
312 // Component may be polymorphic or unlimited polymorphic. Need to use the
313 // dynamic type to check whether finalization is needed.
314 for (std::size_t j{0}; j++ < elements;
315 descriptor.IncrementSubscripts(at)) {
316 const Descriptor &compDesc{
317 *descriptor.ElementComponent<Descriptor>(at, comp.offset())};
318 if (compDesc.IsAllocated()) {
319 if (const DescriptorAddendum * addendum{compDesc.Addendum()}) {
320 if (const typeInfo::DerivedType *
321 compDynamicType{addendum->derivedType()}) {
322 if (!compDynamicType->noFinalizationNeeded()) {
323 Finalize(compDesc, *compDynamicType, terminator);
324 }
325 }
326 }
327 }
328 }
329 } else if (comp.genre() == typeInfo::Component::Genre::Allocatable ||
330 comp.genre() == typeInfo::Component::Genre::Automatic) {
331 if (const typeInfo::DerivedType * compType{comp.derivedType()}) {
332 if (!compType->noFinalizationNeeded()) {
333 for (std::size_t j{0}; j++ < elements;
334 descriptor.IncrementSubscripts(at)) {
335 const Descriptor &compDesc{
336 *descriptor.ElementComponent<Descriptor>(at, comp.offset())};
337 if (compDesc.IsAllocated()) {
338 Finalize(compDesc, *compType, terminator);
339 }
340 }
341 }
342 }
343 } else if (comp.genre() == typeInfo::Component::Genre::Data &&
344 comp.derivedType() && !comp.derivedType()->noFinalizationNeeded()) {
345 SubscriptValue extents[maxRank];
346 GetComponentExtents(extents, comp, descriptor);
347 StaticDescriptor<maxRank, true, 0> staticDescriptor;
348 Descriptor &compDesc{staticDescriptor.descriptor()};
349 const typeInfo::DerivedType &compType{*comp.derivedType()};
350 for (std::size_t j{0}; j++ < elements;
351 descriptor.IncrementSubscripts(at)) {
352 compDesc.Establish(compType,
353 descriptor.ElementComponent<char>(at, comp.offset()), comp.rank(),
354 extents);
355 Finalize(compDesc, compType, terminator);
356 }
357 }
358 }
359 if (recurse) {
360 StaticDescriptor<maxRank, true, 8 /*?*/> statDesc;
361 Descriptor &tmpDesc{statDesc.descriptor()};
362 tmpDesc = descriptor;
363 tmpDesc.raw().attribute = CFI_attribute_pointer;
364 tmpDesc.Addendum()->set_derivedType(parentType);
365 tmpDesc.raw().elem_len = parentType->sizeInBytes();
366 Finalize(tmpDesc, *parentType, terminator);
367 }
368}
369
370// The order of finalization follows Fortran 2018 7.5.6.2, with
371// elementwise finalization of non-parent components taking place
372// before parent component finalization, and with all finalization
373// preceding any deallocation.
374RT_API_ATTRS void Destroy(const Descriptor &descriptor, bool finalize,
375 const typeInfo::DerivedType &derived, Terminator *terminator) {
376 if (derived.noDestructionNeeded() || !descriptor.IsAllocated()) {
377 return;
378 }
379 if (finalize && !derived.noFinalizationNeeded()) {
380 Finalize(descriptor, derived, terminator);
381 }
382 // Deallocate all direct and indirect allocatable and automatic components.
383 // Contrary to finalization, the order of deallocation does not matter.
384 const Descriptor &componentDesc{derived.component()};
385 std::size_t myComponents{componentDesc.Elements()};
386 std::size_t elements{descriptor.Elements()};
387 SubscriptValue at[maxRank];
388 descriptor.GetLowerBounds(at);
389 for (std::size_t k{0}; k < myComponents; ++k) {
390 const auto &comp{
391 *componentDesc.ZeroBasedIndexedElement<typeInfo::Component>(k)};
392 const bool destroyComp{
393 comp.derivedType() && !comp.derivedType()->noDestructionNeeded()};
394 if (comp.genre() == typeInfo::Component::Genre::Allocatable ||
395 comp.genre() == typeInfo::Component::Genre::Automatic) {
396 for (std::size_t j{0}; j < elements; ++j) {
397 Descriptor *d{
398 descriptor.ElementComponent<Descriptor>(at, comp.offset())};
399 if (destroyComp) {
400 Destroy(*d, /*finalize=*/false, *comp.derivedType(), terminator);
401 }
402 d->Deallocate();
403 descriptor.IncrementSubscripts(at);
404 }
405 } else if (destroyComp &&
406 comp.genre() == typeInfo::Component::Genre::Data) {
407 SubscriptValue extents[maxRank];
408 GetComponentExtents(extents, comp, descriptor);
409 StaticDescriptor<maxRank, true, 0> staticDescriptor;
410 Descriptor &compDesc{staticDescriptor.descriptor()};
411 const typeInfo::DerivedType &compType{*comp.derivedType()};
412 for (std::size_t j{0}; j++ < elements;
413 descriptor.IncrementSubscripts(at)) {
414 compDesc.Establish(compType,
415 descriptor.ElementComponent<char>(at, comp.offset()), comp.rank(),
416 extents);
417 Destroy(compDesc, /*finalize=*/false, *comp.derivedType(), terminator);
418 }
419 }
420 }
421}
422
423RT_API_ATTRS bool HasDynamicComponent(const Descriptor &descriptor) {
424 if (const DescriptorAddendum * addendum{descriptor.Addendum()}) {
425 if (const auto *derived = addendum->derivedType()) {
426 // Destruction is needed if and only if there are direct or indirect
427 // allocatable or automatic components.
428 return !derived->noDestructionNeeded();
429 }
430 }
431 return false;
432}
433
434RT_OFFLOAD_API_GROUP_END
435} // namespace Fortran::runtime
436

source code of flang-rt/lib/runtime/derived.cpp